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

Go to the source code of this file.

Functions/Subroutines

subroutine pvdimchk (ictxt, nout, n, matrix, ix, jx, descx, incx, info)
subroutine pmdimchk (ictxt, nout, m, n, matrix, ia, ja, desca, info)
subroutine pvdescchk (ictxt, nout, matrix, descx, dtx, mx, nx, imbx, inbx, mbx, nbx, rsrcx, csrcx, incx, mpx, nqx, iprex, imidx, ipostx, igap, gapmul, info)
subroutine pmdescchk (ictxt, nout, matrix, desca, dta, ma, na, imba, inba, mba, nba, rsrca, csrca, mpa, nqa, iprea, imida, iposta, igap, gapmul, info)
double precision function pdopbl2 (subnam, m, n, kkl, kku)
double precision function pdopbl3 (subnam, m, n, k)
subroutine pxerbla (ictxt, srname, info)
logical function lsame (ca, cb)
logical function lsamen (n, ca, cb)
subroutine icopy (n, sx, incx, sy, incy)
integer function pb_noabort (cinfo)
subroutine pb_infog2l (i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
subroutine pb_ainfog2l (m, n, i, j, desc, nprow, npcol, myrow, mycol, imb1, inb1, mp, nq, ii, jj, prow, pcol, rprow, rpcol)
integer function pb_numroc (n, i, inb, nb, proc, srcproc, nprocs)
subroutine pb_boot ()
subroutine pb_timer (i)
subroutine pb_enable ()
subroutine pb_disable ()
double precision function pb_inquire (tmtype, i)
subroutine pb_combine (ictxt, scope, op, tmtype, n, ibeg, times)
subroutine pb_chkmat (ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
subroutine pb_desctrans (descin, descout)
subroutine pb_descset2 (desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld)
subroutine pb_descinit2 (desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld, info)
subroutine pb_binfo (offd, m, n, imb1, inb1, mb, nb, mrrow, mrcol, lcmt00, mblks, nblks, imbloc, inbloc, lmbloc, lnbloc, ilow, low, iupp, upp)
integer function pilaenv (ictxt, prec)
subroutine pb_locinfo (i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
subroutine pb_initjmp (colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
subroutine pb_initmuladd (muladd0, jmp, imuladd)
subroutine pb_setlocran (seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
subroutine pb_ladd (j, k, i)
subroutine pb_lmul (k, j, i)
subroutine pb_jump (k, muladd, irann, iranm, ima)
subroutine pb_setran (iran, iac)
subroutine pb_jumpit (muladd, irann, iranm)

Function/Subroutine Documentation

◆ icopy()

subroutine icopy ( integer n,
integer, dimension( * ) sx,
integer incx,
integer, dimension( * ) sy,
integer incy )

Definition at line 1755 of file pblastim.f.

1756*
1757* -- LAPACK auxiliary test routine (version 2.1) --
1758* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1759* Courant Institute, Argonne National Lab, and Rice University
1760* February 29, 1992
1761*
1762* .. Scalar Arguments ..
1763 INTEGER INCX, INCY, N
1764* ..
1765* .. Array Arguments ..
1766 INTEGER SX( * ), SY( * )
1767* ..
1768*
1769* Purpose
1770* =======
1771*
1772* ICOPY copies an integer vector x to an integer vector y.
1773* Uses unrolled loops for increments equal to 1.
1774*
1775* Arguments
1776* =========
1777*
1778* N (input) INTEGER
1779* The length of the vectors SX and SY.
1780*
1781* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
1782* The vector X.
1783*
1784* INCX (input) INTEGER
1785* The spacing between consecutive elements of SX.
1786*
1787* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
1788* The vector Y.
1789*
1790* INCY (input) INTEGER
1791* The spacing between consecutive elements of SY.
1792*
1793* =====================================================================
1794*
1795* .. Local Scalars ..
1796 INTEGER I, IX, IY, M, MP1
1797* ..
1798* .. Intrinsic Functions ..
1799 INTRINSIC mod
1800* ..
1801* .. Executable Statements ..
1802*
1803 IF( n.LE.0 )
1804 $ RETURN
1805 IF( incx.EQ.1 .AND. incy.EQ.1 )
1806 $ GO TO 20
1807*
1808* Code for unequal increments or equal increments not equal to 1
1809*
1810 ix = 1
1811 iy = 1
1812 IF( incx.LT.0 )
1813 $ ix = ( -n+1 )*incx + 1
1814 IF( incy.LT.0 )
1815 $ iy = ( -n+1 )*incy + 1
1816 DO 10 i = 1, n
1817 sy( iy ) = sx( ix )
1818 ix = ix + incx
1819 iy = iy + incy
1820 10 CONTINUE
1821 RETURN
1822*
1823* Code for both increments equal to 1
1824*
1825* Clean-up loop
1826*
1827 20 CONTINUE
1828 m = mod( n, 7 )
1829 IF( m.EQ.0 )
1830 $ GO TO 40
1831 DO 30 i = 1, m
1832 sy( i ) = sx( i )
1833 30 CONTINUE
1834 IF( n.LT.7 )
1835 $ RETURN
1836 40 CONTINUE
1837 mp1 = m + 1
1838 DO 50 i = mp1, n, 7
1839 sy( i ) = sx( i )
1840 sy( i+1 ) = sx( i+1 )
1841 sy( i+2 ) = sx( i+2 )
1842 sy( i+3 ) = sx( i+3 )
1843 sy( i+4 ) = sx( i+4 )
1844 sy( i+5 ) = sx( i+5 )
1845 sy( i+6 ) = sx( i+6 )
1846 50 CONTINUE
1847 RETURN
1848*
1849* End of ICOPY
1850*

◆ lsame()

logical function lsame ( character ca,
character cb )

Definition at line 1600 of file pblastim.f.

1601*
1602* -- LAPACK auxiliary routine (version 2.1) --
1603* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1604* Courant Institute, Argonne National Lab, and Rice University
1605* September 30, 1994
1606*
1607* .. Scalar Arguments ..
1608 CHARACTER CA, CB
1609* ..
1610*
1611* Purpose
1612* =======
1613*
1614* LSAME returns .TRUE. if CA is the same letter as CB regardless of
1615* case.
1616*
1617* Arguments
1618* =========
1619*
1620* CA (input) CHARACTER*1
1621* CB (input) CHARACTER*1
1622* CA and CB specify the single characters to be compared.
1623*
1624* =====================================================================
1625*
1626* .. Intrinsic Functions ..
1627 INTRINSIC ichar
1628* ..
1629* .. Local Scalars ..
1630 INTEGER INTA, INTB, ZCODE
1631* ..
1632* .. Executable Statements ..
1633*
1634* Test if the characters are equal
1635*
1636 lsame = ca.EQ.cb
1637 IF( lsame )
1638 $ RETURN
1639*
1640* Now test for equivalence if both characters are alphabetic.
1641*
1642 zcode = ichar( 'Z' )
1643*
1644* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
1645* machines, on which ICHAR returns a value with bit 8 set.
1646* ICHAR('A') on Prime machines returns 193 which is the same as
1647* ICHAR('A') on an EBCDIC machine.
1648*
1649 inta = ichar( ca )
1650 intb = ichar( cb )
1651*
1652 IF( zcode.EQ.90 .OR. zcode.EQ.122 ) THEN
1653*
1654* ASCII is assumed - ZCODE is the ASCII code of either lower or
1655* upper case 'Z'.
1656*
1657 IF( inta.GE.97 .AND. inta.LE.122 ) inta = inta - 32
1658 IF( intb.GE.97 .AND. intb.LE.122 ) intb = intb - 32
1659*
1660 ELSE IF( zcode.EQ.233 .OR. zcode.EQ.169 ) THEN
1661*
1662* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
1663* upper case 'Z'.
1664*
1665 IF( inta.GE.129 .AND. inta.LE.137 .OR.
1666 $ inta.GE.145 .AND. inta.LE.153 .OR.
1667 $ inta.GE.162 .AND. inta.LE.169 ) inta = inta + 64
1668 IF( intb.GE.129 .AND. intb.LE.137 .OR.
1669 $ intb.GE.145 .AND. intb.LE.153 .OR.
1670 $ intb.GE.162 .AND. intb.LE.169 ) intb = intb + 64
1671*
1672 ELSE IF( zcode.EQ.218 .OR. zcode.EQ.250 ) THEN
1673*
1674* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
1675* plus 128 of either lower or upper case 'Z'.
1676*
1677 IF( inta.GE.225 .AND. inta.LE.250 ) inta = inta - 32
1678 IF( intb.GE.225 .AND. intb.LE.250 ) intb = intb - 32
1679 END IF
1680 lsame = inta.EQ.intb
1681*
1682* RETURN
1683*
1684* End of LSAME
1685*
lsame
logical function lsame(ca, cb)
Definition pblastim.f:1601

◆ lsamen()

logical function lsamen ( integer n,
character*( * ) ca,
character*( * ) cb )

Definition at line 1687 of file pblastim.f.

1688*
1689* -- LAPACK auxiliary routine (version 2.1) --
1690* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1691* Courant Institute, Argonne National Lab, and Rice University
1692* September 30, 1994
1693*
1694* .. Scalar Arguments ..
1695 CHARACTER*( * ) CA, CB
1696 INTEGER N
1697* ..
1698*
1699* Purpose
1700* =======
1701*
1702* LSAMEN tests if the first N letters of CA are the same as the
1703* first N letters of CB, regardless of case.
1704* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
1705* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
1706* or LEN( CB ) is less than N.
1707*
1708* Arguments
1709* =========
1710*
1711* N (input) INTEGER
1712* The number of characters in CA and CB to be compared.
1713*
1714* CA (input) CHARACTER*(*)
1715* CB (input) CHARACTER*(*)
1716* CA and CB specify two character strings of length at least N.
1717* Only the first N characters of each string will be accessed.
1718*
1719* =====================================================================
1720*
1721* .. Local Scalars ..
1722 INTEGER I
1723* ..
1724* .. External Functions ..
1725 LOGICAL LSAME
1726 EXTERNAL lsame
1727* ..
1728* .. Intrinsic Functions ..
1729 INTRINSIC len
1730* ..
1731* .. Executable Statements ..
1732*
1733 lsamen = .false.
1734 IF( len( ca ).LT.n .OR. len( cb ).LT.n )
1735 $ GO TO 20
1736*
1737* Do for each character in the two strings.
1738*
1739 DO 10 i = 1, n
1740*
1741* Test if the characters are equal using LSAME.
1742*
1743 IF( .NOT.lsame( ca( i: i ), cb( i: i ) ) )
1744 $ GO TO 20
1745*
1746 10 CONTINUE
1747 lsamen = .true.
1748*
1749 20 CONTINUE
1750 RETURN
1751*
1752* End of LSAMEN
1753*
lsamen
logical function lsamen(n, ca, cb)
Definition pblastim.f:1688

◆ pb_ainfog2l()

subroutine pb_ainfog2l ( integer m,
integer n,
integer i,
integer j,
integer, dimension( * ) desc,
integer nprow,
integer npcol,
integer myrow,
integer mycol,
integer imb1,
integer inb1,
integer mp,
integer nq,
integer ii,
integer jj,
integer prow,
integer pcol,
integer rprow,
integer rpcol )

Definition at line 2251 of file pblastim.f.

2254*
2255* -- PBLAS test routine (version 2.0) --
2256* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2257* and University of California, Berkeley.
2258* April 1, 1998
2259*
2260* .. Scalar Arguments ..
2261 INTEGER I, II, IMB1, INB1, J, JJ, M, MP, MYCOL, MYROW,
2262 $ N, NPCOL, NPROW, NQ, PCOL, PROW, RPCOL, RPROW
2263* ..
2264* .. Array Arguments ..
2265 INTEGER DESC( * )
2266* ..
2267*
2268* Purpose
2269* =======
2270*
2271* PB_AINFOG2L computes the starting local row and column indexes II,
2272* JJ corresponding to the submatrix starting globally at the entry
2273* pointed by I, J. This routine returns the coordinates in the grid of
2274* the process owning the matrix entry of global indexes I, J, namely
2275* PROW and PCOL. In addition, this routine computes the quantities MP
2276* and NQ, which are respectively the local number of rows and columns
2277* owned by the process of coordinate MYROW, MYCOL corresponding to the
2278* global submatrix A(I:I+M-1,J:J+N-1). Finally, the size of the first
2279* partial block and the relative process coordinates are also returned
2280* respectively in IMB, INB and RPROW, RPCOL.
2281*
2282* Notes
2283* =====
2284*
2285* A description vector is associated with each 2D block-cyclicly dis-
2286* tributed matrix. This vector stores the information required to
2287* establish the mapping between a matrix entry and its corresponding
2288* process and memory location.
2289*
2290* In the following comments, the character _ should be read as
2291* "of the distributed matrix". Let A be a generic term for any 2D
2292* block cyclicly distributed matrix. Its description vector is DESCA:
2293*
2294* NOTATION STORED IN EXPLANATION
2295* ---------------- --------------- ------------------------------------
2296* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2297* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2298* the NPROW x NPCOL BLACS process grid
2299* A is distributed over. The context
2300* itself is global, but the handle
2301* (the integer value) may vary.
2302* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2303* ted matrix A, M_A >= 0.
2304* N_A (global) DESCA( N_ ) The number of columns in the distri-
2305* buted matrix A, N_A >= 0.
2306* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2307* block of the matrix A, IMB_A > 0.
2308* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2309* left block of the matrix A,
2310* INB_A > 0.
2311* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2312* bute the last M_A-IMB_A rows of A,
2313* MB_A > 0.
2314* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2315* bute the last N_A-INB_A columns of
2316* A, NB_A > 0.
2317* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2318* row of the matrix A is distributed,
2319* NPROW > RSRC_A >= 0.
2320* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2321* first column of A is distributed.
2322* NPCOL > CSRC_A >= 0.
2323* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2324* array storing the local blocks of
2325* the distributed matrix A,
2326* IF( Lc( 1, N_A ) > 0 )
2327* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2328* ELSE
2329* LLD_A >= 1.
2330*
2331* Let K be the number of rows of a matrix A starting at the global in-
2332* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2333* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2334* receive if these K rows were distributed over NPROW processes. If K
2335* is the number of columns of a matrix A starting at the global index
2336* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2337* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2338* these K columns were distributed over NPCOL processes.
2339*
2340* The values of Lr() and Lc() may be determined via a call to the func-
2341* tion PB_NUMROC:
2342* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2343* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2344*
2345* Arguments
2346* =========
2347*
2348* M (global input) INTEGER
2349* On entry, M specifies the global number of rows of the subma-
2350* trix. M must be at least zero.
2351*
2352* N (global input) INTEGER
2353* On entry, N specifies the global number of columns of the
2354* submatrix. N must be at least zero.
2355*
2356* I (global input) INTEGER
2357* On entry, I specifies the global starting row index of the
2358* submatrix. I must at least one.
2359*
2360* J (global input) INTEGER
2361* On entry, J specifies the global starting column index of
2362* the submatrix. J must at least one.
2363*
2364* DESC (global and local input) INTEGER array
2365* On entry, DESC is an integer array of dimension DLEN_. This
2366* is the array descriptor of the underlying matrix.
2367*
2368* NPROW (global input) INTEGER
2369* On entry, NPROW specifies the total number of process rows
2370* over which the matrix is distributed. NPROW must be at least
2371* one.
2372*
2373* NPCOL (global input) INTEGER
2374* On entry, NPCOL specifies the total number of process columns
2375* over which the matrix is distributed. NPCOL must be at least
2376* one.
2377*
2378* MYROW (local input) INTEGER
2379* On entry, MYROW specifies the row coordinate of the process
2380* whose local index II is determined. MYROW must be at least
2381* zero and strictly less than NPROW.
2382*
2383* MYCOL (local input) INTEGER
2384* On entry, MYCOL specifies the column coordinate of the pro-
2385* cess whose local index JJ is determined. MYCOL must be at
2386* least zero and strictly less than NPCOL.
2387*
2388* IMB1 (global output) INTEGER
2389* On exit, IMB1 specifies the number of rows of the upper left
2390* block of the submatrix. On exit, IMB1 is less or equal than
2391* M and greater or equal than MIN( 1, M ).
2392*
2393* INB1 (global output) INTEGER
2394* On exit, INB1 specifies the number of columns of the upper
2395* left block of the submatrix. On exit, INB1 is less or equal
2396* than N and greater or equal than MIN( 1, N ).
2397*
2398* MP (local output) INTEGER
2399* On exit, MP specifies the local number of rows of the subma-
2400* trix, that the processes of row coordinate MYROW own. MP is
2401* at least zero.
2402*
2403* NQ (local output) INTEGER
2404* On exit, NQ specifies the local number of columns of the
2405* submatrix, that the processes of column coordinate MYCOL
2406* own. NQ is at least zero.
2407*
2408* II (local output) INTEGER
2409* On exit, II specifies the local starting row index of the
2410* submatrix. On exit, II is at least one.
2411*
2412* JJ (local output) INTEGER
2413* On exit, JJ specifies the local starting column index of
2414* the submatrix. On exit, II is at least one.
2415*
2416* PROW (global output) INTEGER
2417* On exit, PROW specifies the row coordinate of the process
2418* that possesses the first row of the submatrix. On exit, PROW
2419* is -1 if DESC(RSRC_) is -1 on input, and, at least zero and
2420* strictly less than NPROW otherwise.
2421*
2422* PCOL (global output) INTEGER
2423* On exit, PCOL specifies the column coordinate of the process
2424* that possesses the first column of the submatrix. On exit,
2425* PCOL is -1 if DESC(CSRC_) is -1 on input, and, at least zero
2426* and strictly less than NPCOL otherwise.
2427*
2428* RPROW (global output) INTEGER
2429* On exit, RPROW specifies the relative row coordinate of the
2430* process that possesses the first row I of the submatrix. On
2431* exit, RPROW is -1 if DESC(RSRC_) is -1 on input, and, at
2432* least zero and strictly less than NPROW otherwise.
2433*
2434* RPCOL (global output) INTEGER
2435* On exit, RPCOL specifies the relative column coordinate of
2436* the process that possesses the first column J of the subma-
2437* trix. On exit, RPCOL is -1 if DESC(CSRC_) is -1 on input,
2438* and, at least zero and strictly less than NPCOL otherwise.
2439*
2440* -- Written on April 1, 1998 by
2441* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2442*
2443* =====================================================================
2444*
2445* .. Parameters ..
2446 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2447 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2448 $ RSRC_
2449 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2450 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2451 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2452 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2453* ..
2454* .. Local Scalars ..
2455 INTEGER CSRC, I1, ILOCBLK, J1, M1, MB, MYDIST, N1, NB,
2456 $ NBLOCKS, RSRC
2457* ..
2458* .. Local Arrays ..
2459 INTEGER DESC2( DLEN_ )
2460* ..
2461* .. External Subroutines ..
2462 EXTERNAL pb_desctrans
2463* ..
2464* .. Intrinsic Functions ..
2465 INTRINSIC min
2466* ..
2467* .. Executable Statements ..
2468*
2469* Convert descriptor
2470*
2471 CALL pb_desctrans( desc, desc2 )
2472*
2473 mb = desc2( mb_ )
2474 imb1 = desc2( imb_ )
2475 rsrc = desc2( rsrc_ )
2476*
2477 IF( ( rsrc.EQ.-1 ).OR.( nprow.EQ.1 ) ) THEN
2478*
2479 ii = i
2480 imb1 = imb1 - i + 1
2481 IF( imb1.LE.0 )
2482 $ imb1 = ( ( -imb1 ) / mb + 1 ) * mb + imb1
2483 imb1 = min( imb1, m )
2484 mp = m
2485 prow = rsrc
2486 rprow = 0
2487*
2488 ELSE
2489*
2490* Figure out PROW, II and IMB1 first
2491*
2492 IF( i.LE.imb1 ) THEN
2493*
2494 prow = rsrc
2495*
2496 IF( myrow.EQ.prow ) THEN
2497 ii = i
2498 ELSE
2499 ii = 1
2500 END IF
2501*
2502 imb1 = imb1 - i + 1
2503*
2504 ELSE
2505*
2506 i1 = i - imb1 - 1
2507 nblocks = i1 / mb + 1
2508 prow = rsrc + nblocks
2509 prow = prow - ( prow / nprow ) * nprow
2510*
2511 IF( myrow.EQ.rsrc ) THEN
2512*
2513 ilocblk = nblocks / nprow
2514*
2515 IF( ilocblk.GT.0 ) THEN
2516 IF( ( ilocblk*nprow ).GE.nblocks ) THEN
2517 IF( myrow.EQ.prow ) THEN
2518 ii = i + ( ilocblk - nblocks ) * mb
2519 ELSE
2520 ii = imb1 + ( ilocblk - 1 ) * mb + 1
2521 END IF
2522 ELSE
2523 ii = imb1 + ilocblk * mb + 1
2524 END IF
2525 ELSE
2526 ii = imb1 + 1
2527 END IF
2528*
2529 ELSE
2530*
2531 mydist = myrow - rsrc
2532 IF( mydist.LT.0 )
2533 $ mydist = mydist + nprow
2534*
2535 ilocblk = nblocks / nprow
2536*
2537 IF( ilocblk.GT.0 ) THEN
2538 mydist = mydist - nblocks + ilocblk * nprow
2539 IF( mydist.LT.0 ) THEN
2540 ii = ( ilocblk + 1 ) * mb + 1
2541 ELSE IF( myrow.EQ.prow ) THEN
2542 ii = i1 + ( ilocblk - nblocks + 1 ) * mb + 1
2543 ELSE
2544 ii = ilocblk * mb + 1
2545 END IF
2546 ELSE
2547 mydist = mydist - nblocks
2548 IF( mydist.LT.0 ) THEN
2549 ii = mb + 1
2550 ELSE IF( myrow.EQ.prow ) THEN
2551 ii = i1 + ( 1 - nblocks ) * mb + 1
2552 ELSE
2553 ii = 1
2554 END IF
2555 END IF
2556 END IF
2557*
2558 imb1 = nblocks * mb - i1
2559*
2560 END IF
2561*
2562* Figure out MP
2563*
2564 IF( m.LE.imb1 ) THEN
2565*
2566 IF( myrow.EQ.prow ) THEN
2567 mp = m
2568 ELSE
2569 mp = 0
2570 END IF
2571*
2572 ELSE
2573*
2574 m1 = m - imb1
2575 nblocks = m1 / mb + 1
2576*
2577 IF( myrow.EQ.prow ) THEN
2578 ilocblk = nblocks / nprow
2579 IF( ilocblk.GT.0 ) THEN
2580 IF( ( nblocks - ilocblk * nprow ).GT.0 ) THEN
2581 mp = imb1 + ilocblk * mb
2582 ELSE
2583 mp = m + mb * ( ilocblk - nblocks )
2584 END IF
2585 ELSE
2586 mp = imb1
2587 END IF
2588 ELSE
2589 mydist = myrow - prow
2590 IF( mydist.LT.0 )
2591 $ mydist = mydist + nprow
2592 ilocblk = nblocks / nprow
2593 IF( ilocblk.GT.0 ) THEN
2594 mydist = mydist - nblocks + ilocblk * nprow
2595 IF( mydist.LT.0 ) THEN
2596 mp = ( ilocblk + 1 ) * mb
2597 ELSE IF( mydist.GT.0 ) THEN
2598 mp = ilocblk * mb
2599 ELSE
2600 mp = m1 + mb * ( ilocblk - nblocks + 1 )
2601 END IF
2602 ELSE
2603 mydist = mydist - nblocks
2604 IF( mydist.LT.0 ) THEN
2605 mp = mb
2606 ELSE IF( mydist.GT.0 ) THEN
2607 mp = 0
2608 ELSE
2609 mp = m1 + mb * ( 1 - nblocks )
2610 END IF
2611 END IF
2612 END IF
2613*
2614 END IF
2615*
2616 imb1 = min( imb1, m )
2617 rprow = myrow - prow
2618 IF( rprow.LT.0 )
2619 $ rprow = rprow + nprow
2620*
2621 END IF
2622*
2623 nb = desc2( nb_ )
2624 inb1 = desc2( inb_ )
2625 csrc = desc2( csrc_ )
2626*
2627 IF( ( csrc.EQ.-1 ).OR.( npcol.EQ.1 ) ) THEN
2628*
2629 jj = j
2630 inb1 = inb1 - i + 1
2631 IF( inb1.LE.0 )
2632 $ inb1 = ( ( -inb1 ) / nb + 1 ) * nb + inb1
2633 inb1 = min( inb1, n )
2634 nq = n
2635 pcol = csrc
2636 rpcol = 0
2637*
2638 ELSE
2639*
2640* Figure out PCOL, JJ and INB1 first
2641*
2642 IF( j.LE.inb1 ) THEN
2643*
2644 pcol = csrc
2645*
2646 IF( mycol.EQ.pcol ) THEN
2647 jj = j
2648 ELSE
2649 jj = 1
2650 END IF
2651*
2652 inb1 = inb1 - j + 1
2653*
2654 ELSE
2655*
2656 j1 = j - inb1 - 1
2657 nblocks = j1 / nb + 1
2658 pcol = csrc + nblocks
2659 pcol = pcol - ( pcol / npcol ) * npcol
2660*
2661 IF( mycol.EQ.csrc ) THEN
2662*
2663 ilocblk = nblocks / npcol
2664*
2665 IF( ilocblk.GT.0 ) THEN
2666 IF( ( ilocblk*npcol ).GE.nblocks ) THEN
2667 IF( mycol.EQ.pcol ) THEN
2668 jj = j + ( ilocblk - nblocks ) * nb
2669 ELSE
2670 jj = inb1 + ( ilocblk - 1 ) * nb + 1
2671 END IF
2672 ELSE
2673 jj = inb1 + ilocblk * nb + 1
2674 END IF
2675 ELSE
2676 jj = inb1 + 1
2677 END IF
2678*
2679 ELSE
2680*
2681 mydist = mycol - csrc
2682 IF( mydist.LT.0 )
2683 $ mydist = mydist + npcol
2684*
2685 ilocblk = nblocks / npcol
2686*
2687 IF( ilocblk.GT.0 ) THEN
2688 mydist = mydist - nblocks + ilocblk * npcol
2689 IF( mydist.LT.0 ) THEN
2690 jj = ( ilocblk + 1 ) * nb + 1
2691 ELSE IF( mycol.EQ.pcol ) THEN
2692 jj = j1 + ( ilocblk - nblocks + 1 ) * nb + 1
2693 ELSE
2694 jj = ilocblk * nb + 1
2695 END IF
2696 ELSE
2697 mydist = mydist - nblocks
2698 IF( mydist.LT.0 ) THEN
2699 jj = nb + 1
2700 ELSE IF( mycol.EQ.pcol ) THEN
2701 jj = j1 + ( 1 - nblocks ) * nb + 1
2702 ELSE
2703 jj = 1
2704 END IF
2705 END IF
2706 END IF
2707*
2708 inb1 = nblocks * nb - j1
2709*
2710 END IF
2711*
2712* Figure out NQ
2713*
2714 IF( n.LE.inb1 ) THEN
2715*
2716 IF( mycol.EQ.pcol ) THEN
2717 nq = n
2718 ELSE
2719 nq = 0
2720 END IF
2721*
2722 ELSE
2723*
2724 n1 = n - inb1
2725 nblocks = n1 / nb + 1
2726*
2727 IF( mycol.EQ.pcol ) THEN
2728 ilocblk = nblocks / npcol
2729 IF( ilocblk.GT.0 ) THEN
2730 IF( ( nblocks - ilocblk * npcol ).GT.0 ) THEN
2731 nq = inb1 + ilocblk * nb
2732 ELSE
2733 nq = n + nb * ( ilocblk - nblocks )
2734 END IF
2735 ELSE
2736 nq = inb1
2737 END IF
2738 ELSE
2739 mydist = mycol - pcol
2740 IF( mydist.LT.0 )
2741 $ mydist = mydist + npcol
2742 ilocblk = nblocks / npcol
2743 IF( ilocblk.GT.0 ) THEN
2744 mydist = mydist - nblocks + ilocblk * npcol
2745 IF( mydist.LT.0 ) THEN
2746 nq = ( ilocblk + 1 ) * nb
2747 ELSE IF( mydist.GT.0 ) THEN
2748 nq = ilocblk * nb
2749 ELSE
2750 nq = n1 + nb * ( ilocblk - nblocks + 1 )
2751 END IF
2752 ELSE
2753 mydist = mydist - nblocks
2754 IF( mydist.LT.0 ) THEN
2755 nq = nb
2756 ELSE IF( mydist.GT.0 ) THEN
2757 nq = 0
2758 ELSE
2759 nq = n1 + nb * ( 1 - nblocks )
2760 END IF
2761 END IF
2762 END IF
2763*
2764 END IF
2765*
2766 inb1 = min( inb1, n )
2767 rpcol = mycol - pcol
2768 IF( rpcol.LT.0 )
2769 $ rpcol = rpcol + npcol
2770*
2771 END IF
2772*
2773 RETURN
2774*
2775* End of PB_AINFOG2L
2776*
min
#define min(a, b)
Definition macros.h:20
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastim.f:3559

◆ pb_binfo()

subroutine pb_binfo ( integer offd,
integer m,
integer n,
integer imb1,
integer inb1,
integer mb,
integer nb,
integer mrrow,
integer mrcol,
integer lcmt00,
integer mblks,
integer nblks,
integer imbloc,
integer inbloc,
integer lmbloc,
integer lnbloc,
integer ilow,
integer low,
integer iupp,
integer upp )

Definition at line 4169 of file pblastim.f.

4172*
4173* -- PBLAS test routine (version 2.0) --
4174* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4175* and University of California, Berkeley.
4176* April 1, 1998
4177*
4178* .. Scalar Arguments ..
4179 INTEGER ILOW, IMB1, IMBLOC, INB1, INBLOC, IUPP, LCMT00,
4180 $ LMBLOC, LNBLOC, LOW, M, MB, MBLKS, MRCOL,
4181 $ MRROW, N, NB, NBLKS, OFFD, UPP
4182* ..
4183*
4184* Purpose
4185* =======
4186*
4187* PB_BINFO initializes the local information of an m by n local array
4188* owned by the process of relative coordinates ( MRROW, MRCOL ). Note
4189* that if m or n is less or equal than zero, there is no data, in which
4190* case this process does not need the local information computed by
4191* this routine to proceed.
4192*
4193* Arguments
4194* =========
4195*
4196* OFFD (global input) INTEGER
4197* On entry, OFFD specifies the off-diagonal of the underlying
4198* matrix of interest as follows:
4199* OFFD = 0 specifies the main diagonal,
4200* OFFD > 0 specifies lower subdiagonals, and
4201* OFFD < 0 specifies upper superdiagonals.
4202*
4203* M (local input) INTEGER
4204* On entry, M specifies the local number of rows of the under-
4205* lying matrix owned by the process of relative coordinates
4206* ( MRROW, MRCOL ). M must be at least zero.
4207*
4208* N (local input) INTEGER
4209* On entry, N specifies the local number of columns of the un-
4210* derlying matrix owned by the process of relative coordinates
4211* ( MRROW, MRCOL ). N must be at least zero.
4212*
4213* IMB1 (global input) INTEGER
4214* On input, IMB1 specifies the global true size of the first
4215* block of rows of the underlying global submatrix. IMB1 must
4216* be at least MIN( 1, M ).
4217*
4218* INB1 (global input) INTEGER
4219* On input, INB1 specifies the global true size of the first
4220* block of columns of the underlying global submatrix. INB1
4221* must be at least MIN( 1, N ).
4222*
4223* MB (global input) INTEGER
4224* On entry, MB specifies the blocking factor used to partition
4225* the rows of the matrix. MB must be at least one.
4226*
4227* NB (global input) INTEGER
4228* On entry, NB specifies the blocking factor used to partition
4229* the the columns of the matrix. NB must be at least one.
4230*
4231* MRROW (local input) INTEGER
4232* On entry, MRROW specifies the relative row coordinate of the
4233* process that possesses these M rows. MRROW must be least zero
4234* and strictly less than NPROW.
4235*
4236* MRCOL (local input) INTEGER
4237* On entry, MRCOL specifies the relative column coordinate of
4238* the process that possesses these N columns. MRCOL must be
4239* least zero and strictly less than NPCOL.
4240*
4241* LCMT00 (local output) INTEGER
4242* On exit, LCMT00 is the LCM value of the left upper block of
4243* this m by n local block owned by the process of relative co-
4244* ordinates ( MRROW, MRCOL ).
4245*
4246* MBLKS (local output) INTEGER
4247* On exit, MBLKS specifies the local number of blocks of rows
4248* corresponding to M. MBLKS must be at least zero.
4249*
4250* NBLKS (local output) INTEGER
4251* On exit, NBLKS specifies the local number of blocks of co-
4252* lumns corresponding to N. NBLKS must be at least zero.
4253*
4254* IMBLOC (local output) INTEGER
4255* On exit, IMBLOC specifies the number of rows (size) of the
4256* uppest blocks of this m by n local array owned by the process
4257* of relative coordinates ( MRROW, MRCOL ). IMBLOC is at least
4258* MIN( 1, M ).
4259*
4260* INBLOC (local output) INTEGER
4261* On exit, INBLOC specifies the number of columns (size) of
4262* the leftmost blocks of this m by n local array owned by the
4263* process of relative coordinates ( MRROW, MRCOL ). INBLOC is
4264* at least MIN( 1, N ).
4265*
4266* LMBLOC (local output) INTEGER
4267* On exit, LMBLOC specifies the number of rows (size) of the
4268* lowest blocks of this m by n local array owned by the process
4269* of relative coordinates ( MRROW, MRCOL ). LMBLOC is at least
4270* MIN( 1, M ).
4271*
4272* LNBLOC (local output) INTEGER
4273* On exit, LNBLOC specifies the number of columns (size) of the
4274* rightmost blocks of this m by n local array owned by the
4275* process of relative coordinates ( MRROW, MRCOL ). LNBLOC is
4276* at least MIN( 1, N ).
4277*
4278* ILOW (local output) INTEGER
4279* On exit, ILOW is the lower bound characterizing the first co-
4280* lumn block owning offdiagonals of this m by n array. ILOW
4281* must be less or equal than zero.
4282*
4283* LOW (global output) INTEGER
4284* On exit, LOW is the lower bound characterizing the column
4285* blocks with te exception of the first one (see ILOW) owning
4286* offdiagonals of this m by n array. LOW must be less or equal
4287* than zero.
4288*
4289* IUPP (local output) INTEGER
4290* On exit, IUPP is the upper bound characterizing the first row
4291* block owning offdiagonals of this m by n array. IUPP must be
4292* greater or equal than zero.
4293*
4294* UPP (global output) INTEGER
4295* On exit, UPP is the upper bound characterizing the row
4296* blocks with te exception of the first one (see IUPP) owning
4297* offdiagonals of this m by n array. UPP must be greater or
4298* equal than zero.
4299*
4300* -- Written on April 1, 1998 by
4301* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4302*
4303* =====================================================================
4304*
4305* .. Local Scalars ..
4306 INTEGER TMP1
4307* ..
4308* .. Intrinsic Functions ..
4309 INTRINSIC max, min
4310* ..
4311* .. Executable Statements ..
4312*
4313* Initialize LOW, ILOW, UPP, IUPP, LMBLOC, LNBLOC, IMBLOC, INBLOC,
4314* MBLKS, NBLKS and LCMT00.
4315*
4316 low = 1 - nb
4317 upp = mb - 1
4318*
4319 lcmt00 = offd
4320*
4321 IF( m.LE.0 .OR. n.LE.0 ) THEN
4322*
4323 IF( mrrow.GT.0 ) THEN
4324 iupp = mb - 1
4325 ELSE
4326 iupp = max( 0, imb1 - 1 )
4327 END IF
4328 imbloc = 0
4329 mblks = 0
4330 lmbloc = 0
4331*
4332 IF( mrcol.GT.0 ) THEN
4333 ilow = 1 - nb
4334 ELSE
4335 ilow = min( 0, 1 - inb1 )
4336 END IF
4337 inbloc = 0
4338 nblks = 0
4339 lnbloc = 0
4340*
4341 lcmt00 = lcmt00 + ( low - ilow + mrcol * nb ) -
4342 $ ( iupp - upp + mrrow * mb )
4343*
4344 RETURN
4345*
4346 END IF
4347*
4348 IF( mrrow.GT.0 ) THEN
4349*
4350 imbloc = min( m, mb )
4351 iupp = mb - 1
4352 lcmt00 = lcmt00 - ( imb1 - mb + mrrow * mb )
4353 mblks = ( m - 1 ) / mb + 1
4354 lmbloc = m - ( m / mb ) * mb
4355 IF( lmbloc.EQ.0 )
4356 $ lmbloc = mb
4357*
4358 IF( mrcol.GT.0 ) THEN
4359*
4360 inbloc = min( n, nb )
4361 ilow = 1 - nb
4362 lcmt00 = lcmt00 + inb1 - nb + mrcol * nb
4363 nblks = ( n - 1 ) / nb + 1
4364 lnbloc = n - ( n / nb ) * nb
4365 IF( lnbloc.EQ.0 )
4366 $ lnbloc = nb
4367*
4368 ELSE
4369*
4370 inbloc = inb1
4371 ilow = 1 - inb1
4372 tmp1 = n - inb1
4373 IF( tmp1.GT.0 ) THEN
4374*
4375* more than one block
4376*
4377 nblks = ( tmp1 - 1 ) / nb + 2
4378 lnbloc = tmp1 - ( tmp1 / nb ) * nb
4379 IF( lnbloc.EQ.0 )
4380 $ lnbloc = nb
4381*
4382 ELSE
4383*
4384 nblks = 1
4385 lnbloc = inb1
4386*
4387 END IF
4388*
4389 END IF
4390*
4391 ELSE
4392*
4393 imbloc = imb1
4394 iupp = imb1 - 1
4395 tmp1 = m - imb1
4396 IF( tmp1.GT.0 ) THEN
4397*
4398* more than one block
4399*
4400 mblks = ( tmp1 - 1 ) / mb + 2
4401 lmbloc = tmp1 - ( tmp1 / mb ) * mb
4402 IF( lmbloc.EQ.0 )
4403 $ lmbloc = mb
4404*
4405 ELSE
4406*
4407 mblks = 1
4408 lmbloc = imb1
4409*
4410 END IF
4411*
4412 IF( mrcol.GT.0 ) THEN
4413*
4414 inbloc = min( n, nb )
4415 ilow = 1 - nb
4416 lcmt00 = lcmt00 + inb1 - nb + mrcol * nb
4417 nblks = ( n - 1 ) / nb + 1
4418 lnbloc = n - ( n / nb ) * nb
4419 IF( lnbloc.EQ.0 )
4420 $ lnbloc = nb
4421*
4422 ELSE
4423*
4424 inbloc = inb1
4425 ilow = 1 - inb1
4426 tmp1 = n - inb1
4427 IF( tmp1.GT.0 ) THEN
4428*
4429* more than one block
4430*
4431 nblks = ( tmp1 - 1 ) / nb + 2
4432 lnbloc = tmp1 - ( tmp1 / nb ) * nb
4433 IF( lnbloc.EQ.0 )
4434 $ lnbloc = nb
4435*
4436 ELSE
4437*
4438 nblks = 1
4439 lnbloc = inb1
4440*
4441 END IF
4442*
4443 END IF
4444*
4445 END IF
4446*
4447 RETURN
4448*
4449* End of PB_BINFO
4450*
max
#define max(a, b)
Definition macros.h:21

◆ pb_boot()

subroutine pb_boot

Definition at line 2926 of file pblastim.f.

2927*
2928* -- PBLAS test routine (version 2.0) --
2929* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2930* and University of California, Berkeley.
2931* April 1, 1998
2932*
2933*
2934* Purpose
2935* =======
2936*
2937* PB_BOOT (re)sets all timers to 0, and enables PB_TIMER.
2938*
2939* -- Written on April 1, 1998 by
2940* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
2941*
2942* =====================================================================
2943*
2944* .. Parameters ..
2945 INTEGER NTIMER
2946 parameter( ntimer = 64 )
2947 DOUBLE PRECISION STARTFLAG, ZERO
2948 parameter( startflag = -5.0d+0, zero = 0.0d+0 )
2949* ..
2950* .. Local Scalars ..
2951 INTEGER I
2952* ..
2953* .. Common Blocks ..
2954 LOGICAL DISABLED
2955 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
2956 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
2957 COMMON /sltimer00/ cpusec, wallsec, cpustart, wallstart, disabled
2958* ..
2959* .. Executable Statements ..
2960*
2961 disabled = .false.
2962 DO 10 i = 1, ntimer
2963 cpusec( i ) = zero
2964 wallsec( i ) = zero
2965 cpustart( i ) = startflag
2966 wallstart( i ) = startflag
2967 10 CONTINUE
2968*
2969 RETURN
2970*
2971* End of PB_BOOT
2972*

◆ pb_chkmat()

subroutine pb_chkmat ( integer ictxt,
integer m,
integer mpos0,
integer n,
integer npos0,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer dpos0,
integer info )

Definition at line 3335 of file pblastim.f.

3337*
3338* -- PBLAS test routine (version 2.0) --
3339* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3340* and University of California, Berkeley.
3341* April 1, 1998
3342*
3343* .. Scalar Arguments ..
3344 INTEGER DPOS0, IA, ICTXT, INFO, JA, M, MPOS0, N, NPOS0
3345* ..
3346* .. Array Arguments ..
3347 INTEGER DESCA( * )
3348* ..
3349*
3350* Purpose
3351* =======
3352*
3353* PB_CHKMAT checks the validity of a descriptor vector DESCA, the re-
3354* lated global indexes IA, JA from a local view point. If an inconsis-
3355* tency is found among its parameters IA, JA and DESCA, the routine re-
3356* turns an error code in INFO.
3357*
3358* Arguments
3359* =========
3360*
3361* ICTXT (local input) INTEGER
3362* On entry, ICTXT specifies the BLACS context handle, indica-
3363* ting the global context of the operation. The context itself
3364* is global, but the value of ICTXT is local.
3365*
3366* M (global input) INTEGER
3367* On entry, M specifies the number of rows the submatrix
3368* sub( A ).
3369*
3370* MPOS0 (global input) INTEGER
3371* On entry, MPOS0 specifies the position in the calling rou-
3372* tine's parameter list where the formal parameter M appears.
3373*
3374* N (global input) INTEGER
3375* On entry, N specifies the number of columns the submatrix
3376* sub( A ).
3377*
3378* NPOS0 (global input) INTEGER
3379* On entry, NPOS0 specifies the position in the calling rou-
3380* tine's parameter list where the formal parameter N appears.
3381*
3382* IA (global input) INTEGER
3383* On entry, IA specifies A's global row index, which points to
3384* the beginning of the submatrix sub( A ).
3385*
3386* JA (global input) INTEGER
3387* On entry, JA specifies A's global column index, which points
3388* to the beginning of the submatrix sub( A ).
3389*
3390* DESCA (global and local input) INTEGER array
3391* On entry, DESCA is an integer array of dimension DLEN_. This
3392* is the array descriptor for the matrix A.
3393*
3394* DPOS0 (global input) INTEGER
3395* On entry, DPOS0 specifies the position in the calling rou-
3396* tine's parameter list where the formal parameter DESCA ap-
3397* pears. Note that it is assumed that IA and JA are respecti-
3398* vely 2 and 1 entries behind DESCA.
3399*
3400* INFO (local input/local output) INTEGER
3401* = 0: successful exit
3402* < 0: If the i-th argument is an array and the j-entry had an
3403* illegal value, then INFO = -(i*100+j), if the i-th
3404* argument is a scalar and had an illegal value, then
3405* INFO = -i.
3406*
3407* -- Written on April 1, 1998 by
3408* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3409*
3410* =====================================================================
3411*
3412* .. Parameters ..
3413 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3414 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3415 $ RSRC_
3416 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3417 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3418 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3419 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3420 INTEGER DESCMULT, BIGNUM
3421 parameter( descmult = 100, bignum = descmult*descmult )
3422* ..
3423* .. Local Scalars ..
3424 INTEGER DPOS, IAPOS, JAPOS, MP, MPOS, MYCOL, MYROW,
3425 $ NPCOL, NPOS, NPROW, NQ
3426* ..
3427* .. Local Arrays ..
3428 INTEGER DESCA2( DLEN_ )
3429* ..
3430* .. External Subroutines ..
3431 EXTERNAL blacs_gridinfo, pb_desctrans
3432* ..
3433* .. External Functions ..
3434 INTEGER PB_NUMROC
3435 EXTERNAL pb_numroc
3436* ..
3437* .. Intrinsic Functions ..
3438 INTRINSIC min, max
3439* ..
3440* .. Executable Statements ..
3441*
3442* Convert descriptor
3443*
3444 CALL pb_desctrans( desca, desca2 )
3445*
3446* Want to find errors with MIN( ), so if no error, set it to a big
3447* number. If there already is an error, multiply by the the des-
3448* criptor multiplier
3449*
3450 IF( info.GE.0 ) THEN
3451 info = bignum
3452 ELSE IF( info.LT.-descmult ) THEN
3453 info = -info
3454 ELSE
3455 info = -info * descmult
3456 END IF
3457*
3458* Figure where in parameter list each parameter was, factoring in
3459* descriptor multiplier
3460*
3461 mpos = mpos0 * descmult
3462 npos = npos0 * descmult
3463 iapos = ( dpos0 - 2 ) * descmult
3464 japos = ( dpos0 - 1 ) * descmult
3465 dpos = dpos0 * descmult
3466*
3467* Get grid parameters
3468*
3469 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3470*
3471* Check that matrix values make sense from local viewpoint
3472*
3473 IF( m.LT.0 )
3474 $ info = min( info, mpos )
3475 IF( n.LT.0 )
3476 $ info = min( info, npos )
3477 IF( ia.LT.1 )
3478 $ info = min( info, iapos )
3479 IF( ja.LT.1 )
3480 $ info = min( info, japos )
3481 IF( desca2( dtype_ ).NE.block_cyclic_2d_inb )
3482 $ info = min( info, dpos + dtype_ )
3483 IF( desca2( imb_ ).LT.1 )
3484 $ info = min( info, dpos + imb_ )
3485 IF( desca2( inb_ ).LT.1 )
3486 $ info = min( info, dpos + inb_ )
3487 IF( desca2( mb_ ).LT.1 )
3488 $ info = min( info, dpos + mb_ )
3489 IF( desca2( nb_ ).LT.1 )
3490 $ info = min( info, dpos + nb_ )
3491 IF( desca2( rsrc_ ).LT.-1 .OR. desca2( rsrc_ ).GE.nprow )
3492 $ info = min( info, dpos + rsrc_ )
3493 IF( desca2( csrc_ ).LT.-1 .OR. desca2( csrc_ ).GE.npcol )
3494 $ info = min( info, dpos + csrc_ )
3495 IF( desca2( ctxt_ ).NE.ictxt )
3496 $ info = min( info, dpos + ctxt_ )
3497*
3498 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
3499*
3500* NULL matrix, relax some checks
3501*
3502 IF( desca2( m_ ).LT.0 )
3503 $ info = min( info, dpos + m_ )
3504 IF( desca2( n_ ).LT.0 )
3505 $ info = min( info, dpos + n_ )
3506 IF( desca2( lld_ ).LT.1 )
3507 $ info = min( info, dpos + lld_ )
3508*
3509 ELSE
3510*
3511* more rigorous checks for non-degenerate matrices
3512*
3513 mp = pb_numroc( desca2( m_ ), 1, desca2( imb_ ), desca2( mb_ ),
3514 $ myrow, desca2( rsrc_ ), nprow )
3515*
3516 IF( desca2( m_ ).LT.1 )
3517 $ info = min( info, dpos + m_ )
3518 IF( desca2( n_ ).LT.1 )
3519 $ info = min( info, dpos + n_ )
3520 IF( ia.GT.desca2( m_ ) )
3521 $ info = min( info, iapos )
3522 IF( ja.GT.desca2( n_ ) )
3523 $ info = min( info, japos )
3524 IF( ia+m-1.GT.desca2( m_ ) )
3525 $ info = min( info, mpos )
3526 IF( ja+n-1.GT.desca2( n_ ) )
3527 $ info = min( info, npos )
3528*
3529 IF( desca2( lld_ ).LT.max( 1, mp ) ) THEN
3530 nq = pb_numroc( desca2( n_ ), 1, desca2( inb_ ),
3531 $ desca2( nb_ ), mycol, desca2( csrc_ ),
3532 $ npcol )
3533 IF( desca2( lld_ ).LT.1 ) THEN
3534 info = min( info, dpos + lld_ )
3535 ELSE IF( nq.GT.0 ) THEN
3536 info = min( info, dpos + lld_ )
3537 END IF
3538 END IF
3539*
3540 END IF
3541*
3542* Prepare output: set info = 0 if no error, and divide by
3543* DESCMULT if error is not in a descriptor entry
3544*
3545 IF( info.EQ.bignum ) THEN
3546 info = 0
3547 ELSE IF( mod( info, descmult ).EQ.0 ) THEN
3548 info = -( info / descmult )
3549 ELSE
3550 info = -info
3551 END IF
3552*
3553 RETURN
3554*
3555* End of PB_CHKMAT
3556*
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pb_numroc
integer function pb_numroc(n, i, inb, nb, proc, srcproc, nprocs)
Definition pblastim.f:2779

◆ pb_combine()

subroutine pb_combine ( integer ictxt,
character*1 scope,
character*1 op,
character*1 tmtype,
integer n,
integer ibeg,
double precision, dimension( n ) times )

Definition at line 3209 of file pblastim.f.

3211*
3212* -- PBLAS test routine (version 2.0) --
3213* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3214* and University of California, Berkeley.
3215* April 1, 1998
3216*
3217* .. Scalar Arguments ..
3218 CHARACTER*1 OP, SCOPE, TMTYPE
3219 INTEGER IBEG, ICTXT, N
3220* ..
3221* .. Array Arguments ..
3222 DOUBLE PRECISION TIMES( N )
3223* ..
3224*
3225* Purpose
3226* =======
3227*
3228* PB_COMBINE returns wall or cpu time that has accumulated in timer I.
3229*
3230* Arguments
3231* =========
3232*
3233* TMTYPE (global input) CHARACTER
3234* On entry, TMTYPE specifies what time will be returned as fol-
3235* lows
3236* = 'W': wall clock time is returned,
3237* = 'C': CPU time is returned (default).
3238*
3239* I (global input) INTEGER
3240* On entry, I specifies the timer to return.
3241*
3242* -- Written on April 1, 1998 by
3243* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3244*
3245* =====================================================================
3246*
3247* .. Parameters ..
3248 INTEGER NTIMER
3249 parameter( ntimer = 64 )
3250 DOUBLE PRECISION ERRFLAG
3251 parameter( errflag = -1.0d+0 )
3252* ..
3253* .. Local Scalars ..
3254 CHARACTER*1 TOP
3255 LOGICAL TMPDIS
3256 INTEGER I
3257* ..
3258* .. External Subroutines ..
3259 EXTERNAL dgamx2d, dgamn2d, dgsum2d, pb_topget
3260* ..
3261* .. External Functions ..
3262 LOGICAL LSAME
3263 DOUBLE PRECISION DCPUTIME00, DWALLTIME00
3264 EXTERNAL dcputime00, dwalltime00, lsame
3265* ..
3266* .. Common Blocks ..
3267 LOGICAL DISABLED
3268 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3269 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3270 COMMON /sltimer00/ cpusec, wallsec, cpustart, wallstart, disabled
3271* ..
3272* .. Executable Statements ..
3273*
3274* Disable timer for combine operation
3275*
3276 tmpdis = disabled
3277 disabled = .true.
3278*
3279* Copy timer information into user's times array
3280*
3281 IF( lsame( tmtype, 'W' ) ) THEN
3282*
3283* If walltime not available on this machine, fill in times
3284* with -1 flag, and return
3285*
3286 IF( dwalltime00().EQ.errflag ) THEN
3287 DO 10 i = 1, n
3288 times( i ) = errflag
3289 10 CONTINUE
3290 RETURN
3291 ELSE
3292 DO 20 i = 1, n
3293 times( i ) = wallsec( ibeg + i - 1 )
3294 20 CONTINUE
3295 END IF
3296 ELSE
3297 IF( dcputime00().EQ.errflag ) THEN
3298 DO 30 i = 1, n
3299 times( i ) = errflag
3300 30 CONTINUE
3301 RETURN
3302 ELSE
3303 DO 40 i = 1, n
3304 times( i ) = cpusec( ibeg + i - 1 )
3305 40 CONTINUE
3306 END IF
3307 ENDIF
3308*
3309* Combine all nodes' information, restore disabled, and return
3310*
3311 IF( op.EQ.'>' ) THEN
3312 CALL pb_topget( ictxt, 'Combine', scope, top )
3313 CALL dgamx2d( ictxt, scope, top, n, 1, times, n, -1, -1,
3314 $ -1, -1, 0 )
3315 ELSE IF( op.EQ.'<' ) THEN
3316 CALL pb_topget( ictxt, 'Combine', scope, top )
3317 CALL dgamn2d( ictxt, scope, top, n, 1, times, n, -1, -1,
3318 $ -1, -1, 0 )
3319 ELSE IF( op.EQ.'+' ) THEN
3320 CALL pb_topget( ictxt, 'Combine', scope, top )
3321 CALL dgsum2d( ictxt, scope, top, n, 1, times, n, -1, 0 )
3322 ELSE
3323 CALL pb_topget( ictxt, 'Combine', scope, top )
3324 CALL dgamx2d( ictxt, scope, top, n, 1, times, n, -1, -1,
3325 $ -1, -1, 0 )
3326 END IF
3327*
3328 disabled = tmpdis
3329*
3330 RETURN
3331*
3332* End of PB_COMBINE
3333*

◆ pb_descinit2()

subroutine pb_descinit2 ( integer, dimension( * ) desc,
integer m,
integer n,
integer imb,
integer inb,
integer mb,
integer nb,
integer rsrc,
integer csrc,
integer ctxt,
integer lld,
integer info )

Definition at line 3930 of file pblastim.f.

3932*
3933* -- PBLAS test routine (version 2.0) --
3934* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3935* and University of California, Berkeley.
3936* April 1, 1998
3937*
3938* .. Scalar Arguments ..
3939 INTEGER CSRC, CTXT, IMB, INB, INFO, LLD, M, MB, N, NB,
3940 $ RSRC
3941* ..
3942* .. Array Arguments ..
3943 INTEGER DESC( * )
3944* ..
3945*
3946* Purpose
3947* =======
3948*
3949* PB_DESCINIT2 uses its 10 input arguments M, N, IMB, INB, MB, NB,
3950* RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type
3951* BLOCK_CYCLIC_2D_INB.
3952*
3953* Notes
3954* =====
3955*
3956* A description vector is associated with each 2D block-cyclicly dis-
3957* tributed matrix. This vector stores the information required to
3958* establish the mapping between a matrix entry and its corresponding
3959* process and memory location.
3960*
3961* In the following comments, the character _ should be read as
3962* "of the distributed matrix". Let A be a generic term for any 2D
3963* block cyclicly distributed matrix. Its description vector is DESCA:
3964*
3965* NOTATION STORED IN EXPLANATION
3966* ---------------- --------------- ------------------------------------
3967* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3968* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3969* the NPROW x NPCOL BLACS process grid
3970* A is distributed over. The context
3971* itself is global, but the handle
3972* (the integer value) may vary.
3973* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3974* ted matrix A, M_A >= 0.
3975* N_A (global) DESCA( N_ ) The number of columns in the distri-
3976* buted matrix A, N_A >= 0.
3977* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3978* block of the matrix A, IMB_A > 0.
3979* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3980* left block of the matrix A,
3981* INB_A > 0.
3982* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3983* bute the last M_A-IMB_A rows of A,
3984* MB_A > 0.
3985* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3986* bute the last N_A-INB_A columns of
3987* A, NB_A > 0.
3988* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3989* row of the matrix A is distributed,
3990* NPROW > RSRC_A >= 0.
3991* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3992* first column of A is distributed.
3993* NPCOL > CSRC_A >= 0.
3994* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3995* array storing the local blocks of
3996* the distributed matrix A,
3997* IF( Lc( 1, N_A ) > 0 )
3998* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3999* ELSE
4000* LLD_A >= 1.
4001*
4002* Let K be the number of rows of a matrix A starting at the global in-
4003* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4004* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4005* receive if these K rows were distributed over NPROW processes. If K
4006* is the number of columns of a matrix A starting at the global index
4007* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4008* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4009* these K columns were distributed over NPCOL processes.
4010*
4011* The values of Lr() and Lc() may be determined via a call to the func-
4012* tion PB_NUMROC:
4013* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4014* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4015*
4016* Arguments
4017* =========
4018*
4019* DESC (global and local output) INTEGER array
4020* On entry, DESC is an array of dimension DLEN_. DESC is the
4021* array descriptor to be set.
4022*
4023* M (global input) INTEGER
4024* On entry, M specifies the number of rows of the matrix.
4025* M must be at least zero.
4026*
4027* N (global input) INTEGER
4028* On entry, N specifies the number of columns of the matrix.
4029* N must be at least zero.
4030*
4031* IMB (global input) INTEGER
4032* On entry, IMB specifies the row size of the first block of
4033* the global matrix distribution. IMB must be at least one.
4034*
4035* INB (global input) INTEGER
4036* On entry, INB specifies the column size of the first block
4037* of the global matrix distribution. INB must be at least one.
4038*
4039* MB (global input) INTEGER
4040* On entry, MB specifies the row size of the blocks used to
4041* partition the matrix. MB must be at least one.
4042*
4043* NB (global input) INTEGER
4044* On entry, NB specifies the column size of the blocks used to
4045* partition the matrix. NB must be at least one.
4046*
4047* RSRC (global input) INTEGER
4048* On entry, RSRC specifies the row coordinate of the process
4049* that possesses the first row of the matrix. When RSRC = -1,
4050* the data is not distributed but replicated, otherwise RSRC
4051* must be at least zero and strictly less than NPROW.
4052*
4053* CSRC (global input) INTEGER
4054* On entry, CSRC specifies the column coordinate of the pro-
4055* cess that possesses the first column of the matrix. When
4056* CSRC = -1, the data is not distributed but replicated, other-
4057* wise CSRC must be at least zero and strictly less than NPCOL.
4058*
4059* CTXT (local input) INTEGER
4060* On entry, CTXT specifies the BLACS context handle, indicating
4061* the global communication context. The value of the context
4062* itself is local.
4063*
4064* LLD (local input) INTEGER
4065* On entry, LLD specifies the leading dimension of the local
4066* array storing the local entries of the matrix. LLD must be at
4067* least MAX( 1, Lr(1,M) ).
4068*
4069* INFO (local output) INTEGER
4070* = 0: successful exit
4071* < 0: if INFO = -i, the i-th argument had an illegal value.
4072*
4073* Notes
4074* =====
4075*
4076* If the routine can recover from an erroneous input argument, it will
4077* return an acceptable descriptor vector. For example, if LLD = 0 on
4078* input, DESC( LLD_ ) will contain the smallest leading dimension re-
4079* quired to store the specified m by n matrix, INFO will however be set
4080* to -11 on exit in that case.
4081*
4082* -- Written on April 1, 1998 by
4083* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4084*
4085* =====================================================================
4086*
4087* .. Parameters ..
4088 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4089 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4090 $ RSRC_
4091 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
4092 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
4093 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
4094 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
4095* ..
4096* .. Local Scalars ..
4097 INTEGER LLDMIN, MP, MYCOL, MYROW, NPCOL, NPROW
4098* ..
4099* .. External Subroutines ..
4100 EXTERNAL blacs_gridinfo, pxerbla
4101* ..
4102* .. External Functions ..
4103 INTEGER PB_NUMROC
4104 EXTERNAL pb_numroc
4105* ..
4106* .. Intrinsic Functions ..
4107 INTRINSIC max, min
4108* ..
4109* .. Executable Statements ..
4110*
4111* Get grid parameters
4112*
4113 CALL blacs_gridinfo( ctxt, nprow, npcol, myrow, mycol )
4114*
4115 info = 0
4116 IF( m.LT.0 ) THEN
4117 info = -2
4118 ELSE IF( n.LT.0 ) THEN
4119 info = -3
4120 ELSE IF( imb.LT.1 ) THEN
4121 info = -4
4122 ELSE IF( inb.LT.1 ) THEN
4123 info = -5
4124 ELSE IF( mb.LT.1 ) THEN
4125 info = -6
4126 ELSE IF( nb.LT.1 ) THEN
4127 info = -7
4128 ELSE IF( rsrc.LT.-1 .OR. rsrc.GE.nprow ) THEN
4129 info = -8
4130 ELSE IF( csrc.LT.-1 .OR. csrc.GE.npcol ) THEN
4131 info = -9
4132 ELSE IF( nprow.EQ.-1 ) THEN
4133 info = -10
4134 END IF
4135*
4136* Compute minimum LLD if safe (to avoid division by 0)
4137*
4138 IF( info.EQ.0 ) THEN
4139 mp = pb_numroc( m, 1, imb, mb, myrow, rsrc, nprow )
4140 IF( pb_numroc( n, 1, inb, nb, mycol, csrc, npcol ).GT.0 ) THEN
4141 lldmin = max( 1, mp )
4142 ELSE
4143 lldmin = 1
4144 END IF
4145 IF( lld.LT.lldmin )
4146 $ info = -11
4147 END IF
4148*
4149 IF( info.NE.0 )
4150 $ CALL pxerbla( ctxt, 'PB_DESCINIT2', -info )
4151*
4152 desc( dtype_ ) = block_cyclic_2d_inb
4153 desc( ctxt_ ) = ctxt
4154 desc( m_ ) = max( 0, m )
4155 desc( n_ ) = max( 0, n )
4156 desc( imb_ ) = max( 1, imb )
4157 desc( inb_ ) = max( 1, inb )
4158 desc( mb_ ) = max( 1, mb )
4159 desc( nb_ ) = max( 1, nb )
4160 desc( rsrc_ ) = max( -1, min( rsrc, nprow-1 ) )
4161 desc( csrc_ ) = max( -1, min( csrc, npcol-1 ) )
4162 desc( lld_ ) = max( lld, lldmin )
4163*
4164 RETURN
4165*
4166* End of PB_DESCINIT2
4167*
pxerbla
subroutine pxerbla(ictxt, srname, info)
Definition pblastim.f:1538

◆ pb_descset2()

subroutine pb_descset2 ( integer, dimension( * ) desc,
integer m,
integer n,
integer imb,
integer inb,
integer mb,
integer nb,
integer rsrc,
integer csrc,
integer ctxt,
integer lld )

Definition at line 3765 of file pblastim.f.

3767*
3768* -- PBLAS test routine (version 2.0) --
3769* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3770* and University of California, Berkeley.
3771* April 1, 1998
3772*
3773* .. Scalar Arguments ..
3774 INTEGER CSRC, CTXT, IMB, INB, LLD, M, MB, N, NB, RSRC
3775* ..
3776* .. Array Arguments ..
3777 INTEGER DESC( * )
3778* ..
3779*
3780* Purpose
3781* =======
3782*
3783* PB_DESCSET2 uses its 10 input arguments M, N, IMB, INB, MB, NB,
3784* RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type
3785* BLOCK_CYCLIC_2D_INB.
3786*
3787* Notes
3788* =====
3789*
3790* A description vector is associated with each 2D block-cyclicly dis-
3791* tributed matrix. This vector stores the information required to
3792* establish the mapping between a matrix entry and its corresponding
3793* process and memory location.
3794*
3795* In the following comments, the character _ should be read as
3796* "of the distributed matrix". Let A be a generic term for any 2D
3797* block cyclicly distributed matrix. Its description vector is DESCA:
3798*
3799* NOTATION STORED IN EXPLANATION
3800* ---------------- --------------- -----------------------------------
3801* DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type.
3802* CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating
3803* the NPROW x NPCOL BLACS process
3804* grid A is distributed over. The
3805* context itself is global, but the
3806* handle (the integer value) may
3807* vary.
3808* M_A (global) DESCA( M1_ ) The number of rows in the distri-
3809* buted matrix A, M_A >= 0.
3810* N_A (global) DESCA( N1_ ) The number of columns in the dis-
3811* tributed matrix A, N_A >= 0.
3812* MB_A (global) DESCA( MB1_ ) The blocking factor used to distri-
3813* bute the rows of A, MB_A > 0.
3814* NB_A (global) DESCA( NB1_ ) The blocking factor used to distri-
3815* bute the columns of A, NB_A > 0.
3816* RSRC_A (global) DESCA( RSRC1_ ) The process row over which the
3817* first row of the matrix A is dis-
3818* tributed, NPROW > RSRC_A >= 0.
3819* CSRC_A (global) DESCA( CSRC1_ ) The process column over which the
3820* first column of A is distributed.
3821* NPCOL > CSRC_A >= 0.
3822* LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local
3823* array storing the local blocks of
3824* the distributed matrix A,
3825* IF( Lc( 1, N_A ) > 0 )
3826* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3827* ELSE
3828* LLD_A >= 1.
3829*
3830* Let K be the number of rows of a matrix A starting at the global in-
3831* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3832* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3833* receive if these K rows were distributed over NPROW processes. If K
3834* is the number of columns of a matrix A starting at the global index
3835* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3836* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3837* these K columns were distributed over NPCOL processes.
3838*
3839* The values of Lr() and Lc() may be determined via a call to the func-
3840* tion PB_NUMROC:
3841* Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW )
3842* Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3843*
3844* Arguments
3845* =========
3846*
3847* DESC (global and local output) INTEGER array
3848* On entry, DESC is an array of dimension DLEN_. DESC is the
3849* array descriptor to be set.
3850*
3851* M (global input) INTEGER
3852* On entry, M specifies the number of rows of the matrix.
3853* M must be at least zero.
3854*
3855* N (global input) INTEGER
3856* On entry, N specifies the number of columns of the matrix.
3857* N must be at least zero.
3858*
3859* IMB (global input) INTEGER
3860* On entry, IMB specifies the row size of the first block of
3861* the global matrix distribution. IMB must be at least one.
3862*
3863* INB (global input) INTEGER
3864* On entry, INB specifies the column size of the first block
3865* of the global matrix distribution. INB must be at least one.
3866*
3867* MB (global input) INTEGER
3868* On entry, MB specifies the row size of the blocks used to
3869* partition the matrix. MB must be at least one.
3870*
3871* NB (global input) INTEGER
3872* On entry, NB specifies the column size of the blocks used to
3873* partition the matrix. NB must be at least one.
3874*
3875* RSRC (global input) INTEGER
3876* On entry, RSRC specifies the row coordinate of the process
3877* that possesses the first row of the matrix. When RSRC = -1,
3878* the data is not distributed but replicated, otherwise RSRC
3879* must be at least zero and strictly less than NPROW.
3880*
3881* CSRC (global input) INTEGER
3882* On entry, CSRC specifies the column coordinate of the pro-
3883* cess that possesses the first column of the matrix. When
3884* CSRC = -1, the data is not distributed but replicated, other-
3885* wise CSRC must be at least zero and strictly less than NPCOL.
3886*
3887* CTXT (local input) INTEGER
3888* On entry, CTXT specifies the BLACS context handle, indicating
3889* the global communication context. The value of the context
3890* itself is local.
3891*
3892* LLD (local input) INTEGER
3893* On entry, LLD specifies the leading dimension of the local
3894* array storing the local entries of the matrix. LLD must be at
3895* least MAX( 1, Lr(1,M) ).
3896*
3897* -- Written on April 1, 1998 by
3898* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3899*
3900* =====================================================================
3901*
3902* .. Parameters ..
3903 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3904 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3905 $ RSRC_
3906 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3907 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3908 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3909 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3910* ..
3911* .. Executable Statements ..
3912*
3913 desc( dtype_ ) = block_cyclic_2d_inb
3914 desc( ctxt_ ) = ctxt
3915 desc( m_ ) = m
3916 desc( n_ ) = n
3917 desc( imb_ ) = imb
3918 desc( inb_ ) = inb
3919 desc( mb_ ) = mb
3920 desc( nb_ ) = nb
3921 desc( rsrc_ ) = rsrc
3922 desc( csrc_ ) = csrc
3923 desc( lld_ ) = lld
3924*
3925 RETURN
3926*
3927* End of PB_DESCSET2
3928*

◆ pb_desctrans()

subroutine pb_desctrans ( integer, dimension( * ) descin,
integer, dimension( * ) descout )

Definition at line 3558 of file pblastim.f.

3559*
3560* -- PBLAS test routine (version 2.0) --
3561* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3562* and University of California, Berkeley.
3563* April 1, 1998
3564*
3565* .. Array Arguments ..
3566 INTEGER DESCIN( * ), DESCOUT( * )
3567* ..
3568*
3569* Purpose
3570* =======
3571*
3572* PB_DESCTRANS converts a descriptor DESCIN of type BLOCK_CYCLIC_2D
3573* or BLOCK_CYCLIC_INB_2D into a descriptor DESCOUT of type
3574* BLOCK_CYCLIC_INB_2D.
3575*
3576* Notes
3577* =====
3578*
3579* A description vector is associated with each 2D block-cyclicly dis-
3580* tributed matrix. This vector stores the information required to
3581* establish the mapping between a matrix entry and its corresponding
3582* process and memory location.
3583*
3584* In the following comments, the character _ should be read as
3585* "of the distributed matrix". Let A be a generic term for any 2D
3586* block cyclicly distributed matrix. Its description vector is DESCA:
3587*
3588* NOTATION STORED IN EXPLANATION
3589* ---------------- --------------- -----------------------------------
3590* DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type.
3591* CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating
3592* the NPROW x NPCOL BLACS process
3593* grid A is distributed over. The
3594* context itself is global, but the
3595* handle (the integer value) may
3596* vary.
3597* M_A (global) DESCA( M1_ ) The number of rows in the distri-
3598* buted matrix A, M_A >= 0.
3599* N_A (global) DESCA( N1_ ) The number of columns in the dis-
3600* tributed matrix A, N_A >= 0.
3601* MB_A (global) DESCA( MB1_ ) The blocking factor used to distri-
3602* bute the rows of A, MB_A > 0.
3603* NB_A (global) DESCA( NB1_ ) The blocking factor used to distri-
3604* bute the columns of A, NB_A > 0.
3605* RSRC_A (global) DESCA( RSRC1_ ) The process row over which the
3606* first row of the matrix A is dis-
3607* tributed, NPROW > RSRC_A >= 0.
3608* CSRC_A (global) DESCA( CSRC1_ ) The process column over which the
3609* first column of A is distributed.
3610* NPCOL > CSRC_A >= 0.
3611* LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local
3612* array storing the local blocks of
3613* the distributed matrix A,
3614* IF( Lc( 1, N_A ) > 0 )
3615* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3616* ELSE
3617* LLD_A >= 1.
3618*
3619* Let K be the number of rows of a matrix A starting at the global in-
3620* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3621* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3622* receive if these K rows were distributed over NPROW processes. If K
3623* is the number of columns of a matrix A starting at the global index
3624* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3625* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3626* these K columns were distributed over NPCOL processes.
3627*
3628* The values of Lr() and Lc() may be determined via a call to the func-
3629* tion PB_NUMROC:
3630* Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW )
3631* Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3632*
3633* A description vector is associated with each 2D block-cyclicly dis-
3634* tributed matrix. This vector stores the information required to
3635* establish the mapping between a matrix entry and its corresponding
3636* process and memory location.
3637*
3638* In the following comments, the character _ should be read as
3639* "of the distributed matrix". Let A be a generic term for any 2D
3640* block cyclicly distributed matrix. Its description vector is DESCA:
3641*
3642* NOTATION STORED IN EXPLANATION
3643* ---------------- --------------- ------------------------------------
3644* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3645* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3646* the NPROW x NPCOL BLACS process grid
3647* A is distributed over. The context
3648* itself is global, but the handle
3649* (the integer value) may vary.
3650* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3651* ted matrix A, M_A >= 0.
3652* N_A (global) DESCA( N_ ) The number of columns in the distri-
3653* buted matrix A, N_A >= 0.
3654* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3655* block of the matrix A, IMB_A > 0.
3656* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3657* left block of the matrix A,
3658* INB_A > 0.
3659* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3660* bute the last M_A-IMB_A rows of A,
3661* MB_A > 0.
3662* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3663* bute the last N_A-INB_A columns of
3664* A, NB_A > 0.
3665* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3666* row of the matrix A is distributed,
3667* NPROW > RSRC_A >= 0.
3668* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3669* first column of A is distributed.
3670* NPCOL > CSRC_A >= 0.
3671* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3672* array storing the local blocks of
3673* the distributed matrix A,
3674* IF( Lc( 1, N_A ) > 0 )
3675* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3676* ELSE
3677* LLD_A >= 1.
3678*
3679* Let K be the number of rows of a matrix A starting at the global in-
3680* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3681* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3682* receive if these K rows were distributed over NPROW processes. If K
3683* is the number of columns of a matrix A starting at the global index
3684* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3685* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3686* these K columns were distributed over NPCOL processes.
3687*
3688* The values of Lr() and Lc() may be determined via a call to the func-
3689* tion PB_NUMROC:
3690* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3691* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3692*
3693* Arguments
3694* =========
3695*
3696* DESCIN (global and local input) INTEGER array
3697* On entry, DESCIN is an array of dimension DLEN1_ or DLEN_ as
3698* specified by its first entry DESCIN( DTYPE_ ). DESCIN is the
3699* source array descriptor of type BLOCK_CYCLIC_2D or of type
3700* BLOCK_CYCLIC_2D_INB.
3701*
3702* DESCOUT (global and local output) INTEGER array
3703* On entry, DESCOUT is an array of dimension DLEN_. DESCOUT is
3704* the target array descriptor of type BLOCK_CYCLIC_2D_INB.
3705*
3706* -- Written on April 1, 1998 by
3707* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3708*
3709* =====================================================================
3710*
3711* .. Parameters ..
3712 INTEGER BLOCK_CYCLIC_2D, CSRC1_, CTXT1_, DLEN1_,
3713 $ DTYPE1_, LLD1_, M1_, MB1_, N1_, NB1_, RSRC1_
3714 parameter( block_cyclic_2d = 1, dlen1_ = 9, dtype1_ = 1,
3715 $ ctxt1_ = 2, m1_ = 3, n1_ = 4, mb1_ = 5,
3716 $ nb1_ = 6, rsrc1_ = 7, csrc1_ = 8, lld1_ = 9 )
3717 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3718 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3719 $ RSRC_
3720 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3721 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3722 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3723 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3724* ..
3725* .. Local Scalars ..
3726 INTEGER I
3727* ..
3728* .. Executable Statements ..
3729*
3730 IF( descin( dtype_ ).EQ.block_cyclic_2d ) THEN
3731 descout( dtype_ ) = block_cyclic_2d_inb
3732 descout( ctxt_ ) = descin( ctxt1_ )
3733 descout( m_ ) = descin( m1_ )
3734 descout( n_ ) = descin( n1_ )
3735 descout( imb_ ) = descin( mb1_ )
3736 descout( inb_ ) = descin( nb1_ )
3737 descout( mb_ ) = descin( mb1_ )
3738 descout( nb_ ) = descin( nb1_ )
3739 descout( rsrc_ ) = descin( rsrc1_ )
3740 descout( csrc_ ) = descin( csrc1_ )
3741 descout( lld_ ) = descin( lld1_ )
3742 ELSE IF( descin( dtype_ ).EQ.block_cyclic_2d_inb ) THEN
3743 DO 10 i = 1, dlen_
3744 descout( i ) = descin( i )
3745 10 CONTINUE
3746 ELSE
3747 descout( dtype_ ) = descin( 1 )
3748 descout( ctxt_ ) = descin( 2 )
3749 descout( m_ ) = 0
3750 descout( n_ ) = 0
3751 descout( imb_ ) = 1
3752 descout( inb_ ) = 1
3753 descout( mb_ ) = 1
3754 descout( nb_ ) = 1
3755 descout( rsrc_ ) = 0
3756 descout( csrc_ ) = 0
3757 descout( lld_ ) = 1
3758 END IF
3759*
3760 RETURN
3761*
3762* End of PB_DESCTRANS
3763*

◆ pb_disable()

subroutine pb_disable

Definition at line 3091 of file pblastim.f.

3092*
3093* -- PBLAS test routine (version 2.0) --
3094* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3095* and University of California, Berkeley.
3096* April 1, 1998
3097*
3098* Purpose
3099* =======
3100*
3101* PB_DISABLE sets it so calls to PB_TIMER are ignored.
3102*
3103* -- Written on April 1, 1998 by
3104* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3105*
3106* =====================================================================
3107*
3108* .. Parameters ..
3109 INTEGER NTIMER
3110 parameter( ntimer = 64 )
3111* ..
3112* .. Common Blocks ..
3113 LOGICAL DISABLED
3114 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3115 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3116 COMMON /sltimer00/ cpusec, wallsec, cpustart, wallstart, disabled
3117* ..
3118* .. Executable Statements ..
3119*
3120 disabled = .true.
3121*
3122 RETURN
3123*
3124* End of PB_DISABLE
3125*

◆ pb_enable()

subroutine pb_enable

Definition at line 3053 of file pblastim.f.

3054*
3055* -- PBLAS test routine (version 2.0) --
3056* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3057* and University of California, Berkeley.
3058* April 1, 1998
3059*
3060*
3061* Purpose
3062* =======
3063*
3064* PB_ENABLE sets it so calls to PB_TIMER are not ignored.
3065*
3066* -- Written on April 1, 1998 by
3067* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3068*
3069* =====================================================================
3070*
3071* .. Parameters ..
3072 INTEGER NTIMER
3073 parameter( ntimer = 64 )
3074* ..
3075* .. Common Blocks ..
3076 LOGICAL DISABLED
3077 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3078 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3079 COMMON /sltimer00/ cpusec, wallsec, cpustart, wallstart, disabled
3080* ..
3081* .. Executable Statements ..
3082*
3083 disabled = .false.
3084*
3085 RETURN
3086*
3087* End of PB_ENABLE
3088*

◆ pb_infog2l()

subroutine pb_infog2l ( integer i,
integer j,
integer, dimension( * ) desc,
integer nprow,
integer npcol,
integer myrow,
integer mycol,
integer ii,
integer jj,
integer prow,
integer pcol )

Definition at line 1902 of file pblastim.f.

1904*
1905* -- PBLAS test routine (version 2.0) --
1906* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1907* and University of California, Berkeley.
1908* April 1, 1998
1909*
1910* .. Scalar Arguments ..
1911 INTEGER I, II, J, JJ, MYCOL, MYROW, NPCOL, NPROW, PCOL,
1912 $ PROW
1913* ..
1914* .. Array Arguments ..
1915 INTEGER DESC( * )
1916* ..
1917*
1918* Purpose
1919* =======
1920*
1921* PB_INFOG2L computes the starting local index II, JJ corresponding to
1922* the submatrix starting globally at the entry pointed by I, J. This
1923* routine returns the coordinates in the grid of the process owning the
1924* matrix entry of global indexes I, J, namely PROW and PCOL.
1925*
1926* Notes
1927* =====
1928*
1929* A description vector is associated with each 2D block-cyclicly dis-
1930* tributed matrix. This vector stores the information required to
1931* establish the mapping between a matrix entry and its corresponding
1932* process and memory location.
1933*
1934* In the following comments, the character _ should be read as
1935* "of the distributed matrix". Let A be a generic term for any 2D
1936* block cyclicly distributed matrix. Its description vector is DESCA:
1937*
1938* NOTATION STORED IN EXPLANATION
1939* ---------------- --------------- ------------------------------------
1940* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1941* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1942* the NPROW x NPCOL BLACS process grid
1943* A is distributed over. The context
1944* itself is global, but the handle
1945* (the integer value) may vary.
1946* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1947* ted matrix A, M_A >= 0.
1948* N_A (global) DESCA( N_ ) The number of columns in the distri-
1949* buted matrix A, N_A >= 0.
1950* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1951* block of the matrix A, IMB_A > 0.
1952* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1953* left block of the matrix A,
1954* INB_A > 0.
1955* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1956* bute the last M_A-IMB_A rows of A,
1957* MB_A > 0.
1958* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1959* bute the last N_A-INB_A columns of
1960* A, NB_A > 0.
1961* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1962* row of the matrix A is distributed,
1963* NPROW > RSRC_A >= 0.
1964* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1965* first column of A is distributed.
1966* NPCOL > CSRC_A >= 0.
1967* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1968* array storing the local blocks of
1969* the distributed matrix A,
1970* IF( Lc( 1, N_A ) > 0 )
1971* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1972* ELSE
1973* LLD_A >= 1.
1974*
1975* Let K be the number of rows of a matrix A starting at the global in-
1976* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1977* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1978* receive if these K rows were distributed over NPROW processes. If K
1979* is the number of columns of a matrix A starting at the global index
1980* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1981* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1982* these K columns were distributed over NPCOL processes.
1983*
1984* The values of Lr() and Lc() may be determined via a call to the func-
1985* tion PB_NUMROC:
1986* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1987* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1988*
1989* Arguments
1990* =========
1991*
1992* I (global input) INTEGER
1993* On entry, I specifies the global starting row index of the
1994* submatrix. I must at least one.
1995*
1996* J (global input) INTEGER
1997* On entry, J specifies the global starting column index of
1998* the submatrix. J must at least one.
1999*
2000* DESC (global and local input) INTEGER array
2001* On entry, DESC is an integer array of dimension DLEN_. This
2002* is the array descriptor of the underlying matrix.
2003*
2004* NPROW (global input) INTEGER
2005* On entry, NPROW specifies the total number of process rows
2006* over which the matrix is distributed. NPROW must be at least
2007* one.
2008*
2009* NPCOL (global input) INTEGER
2010* On entry, NPCOL specifies the total number of process columns
2011* over which the matrix is distributed. NPCOL must be at least
2012* one.
2013*
2014* MYROW (local input) INTEGER
2015* On entry, MYROW specifies the row coordinate of the process
2016* whose local index II is determined. MYROW must be at least
2017* zero and strictly less than NPROW.
2018*
2019* MYCOL (local input) INTEGER
2020* On entry, MYCOL specifies the column coordinate of the pro-
2021* cess whose local index JJ is determined. MYCOL must be at
2022* least zero and strictly less than NPCOL.
2023*
2024* II (local output) INTEGER
2025* On exit, II specifies the local starting row index of the
2026* submatrix. On exit, II is at least one.
2027*
2028* JJ (local output) INTEGER
2029* On exit, JJ specifies the local starting column index of the
2030* submatrix. On exit, JJ is at least one.
2031*
2032* PROW (global output) INTEGER
2033* On exit, PROW specifies the row coordinate of the process
2034* that possesses the first row of the submatrix. On exit, PROW
2035* is -1 if DESC( RSRC_ ) is -1 on input, and, at least zero
2036* and strictly less than NPROW otherwise.
2037*
2038* PCOL (global output) INTEGER
2039* On exit, PCOL specifies the column coordinate of the process
2040* that possesses the first column of the submatrix. On exit,
2041* PCOL is -1 if DESC( CSRC_ ) is -1 on input, and, at least
2042* zero and strictly less than NPCOL otherwise.
2043*
2044* -- Written on April 1, 1998 by
2045* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2046*
2047* =====================================================================
2048*
2049* .. Parameters ..
2050 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2051 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2052 $ RSRC_
2053 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2054 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2055 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2056 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2057* ..
2058* .. Local Scalars ..
2059 INTEGER CSRC, I1, ILOCBLK, IMB, INB, J1, MB, MYDIST,
2060 $ NB, NBLOCKS, RSRC
2061* ..
2062* .. Local Arrays ..
2063 INTEGER DESC2( DLEN_ )
2064* ..
2065* .. External Subroutines ..
2066 EXTERNAL pb_desctrans
2067* ..
2068* .. Executable Statements ..
2069*
2070* Convert descriptor
2071*
2072 CALL pb_desctrans( desc, desc2 )
2073*
2074 imb = desc2( imb_ )
2075 prow = desc2( rsrc_ )
2076*
2077* Has every process row I ?
2078*
2079 IF( ( prow.EQ.-1 ).OR.( nprow.EQ.1 ) ) THEN
2080*
2081 ii = i
2082*
2083 ELSE IF( i.LE.imb ) THEN
2084*
2085* I is in range of first block
2086*
2087 IF( myrow.EQ.prow ) THEN
2088 ii = i
2089 ELSE
2090 ii = 1
2091 END IF
2092*
2093 ELSE
2094*
2095* I is not in first block of matrix, figure out who has it.
2096*
2097 rsrc = prow
2098 mb = desc2( mb_ )
2099*
2100 IF( myrow.EQ.rsrc ) THEN
2101*
2102 nblocks = ( i - imb - 1 ) / mb + 1
2103 prow = prow + nblocks
2104 prow = prow - ( prow / nprow ) * nprow
2105*
2106 ilocblk = nblocks / nprow
2107*
2108 IF( ilocblk.GT.0 ) THEN
2109 IF( ( ilocblk*nprow ).GE.nblocks ) THEN
2110 IF( myrow.EQ.prow ) THEN
2111 ii = i + ( ilocblk - nblocks ) * mb
2112 ELSE
2113 ii = imb + ( ilocblk - 1 ) * mb + 1
2114 END IF
2115 ELSE
2116 ii = imb + ilocblk * mb + 1
2117 END IF
2118 ELSE
2119 ii = imb + 1
2120 END IF
2121*
2122 ELSE
2123*
2124 i1 = i - imb
2125 nblocks = ( i1 - 1 ) / mb + 1
2126 prow = prow + nblocks
2127 prow = prow - ( prow / nprow ) * nprow
2128*
2129 mydist = myrow - rsrc
2130 IF( mydist.LT.0 )
2131 $ mydist = mydist + nprow
2132*
2133 ilocblk = nblocks / nprow
2134*
2135 IF( ilocblk.GT.0 ) THEN
2136 mydist = mydist - nblocks + ilocblk * nprow
2137 IF( mydist.LT.0 ) THEN
2138 ii = mb + ilocblk * mb + 1
2139 ELSE
2140 IF( myrow.EQ.prow ) THEN
2141 ii = i1 + ( ilocblk - nblocks + 1 ) * mb
2142 ELSE
2143 ii = ilocblk * mb + 1
2144 END IF
2145 END IF
2146 ELSE
2147 mydist = mydist - nblocks
2148 IF( mydist.LT.0 ) THEN
2149 ii = mb + 1
2150 ELSE IF( myrow.EQ.prow ) THEN
2151 ii = i1 + ( 1 - nblocks ) * mb
2152 ELSE
2153 ii = 1
2154 END IF
2155 END IF
2156 END IF
2157*
2158 END IF
2159*
2160 inb = desc2( inb_ )
2161 pcol = desc2( csrc_ )
2162*
2163* Has every process column J ?
2164*
2165 IF( ( pcol.EQ.-1 ).OR.( npcol.EQ.1 ) ) THEN
2166*
2167 jj = j
2168*
2169 ELSE IF( j.LE.inb ) THEN
2170*
2171* J is in range of first block
2172*
2173 IF( mycol.EQ.pcol ) THEN
2174 jj = j
2175 ELSE
2176 jj = 1
2177 END IF
2178*
2179 ELSE
2180*
2181* J is not in first block of matrix, figure out who has it.
2182*
2183 csrc = pcol
2184 nb = desc2( nb_ )
2185*
2186 IF( mycol.EQ.csrc ) THEN
2187*
2188 nblocks = ( j - inb - 1 ) / nb + 1
2189 pcol = pcol + nblocks
2190 pcol = pcol - ( pcol / npcol ) * npcol
2191*
2192 ilocblk = nblocks / npcol
2193*
2194 IF( ilocblk.GT.0 ) THEN
2195 IF( ( ilocblk*npcol ).GE.nblocks ) THEN
2196 IF( mycol.EQ.pcol ) THEN
2197 jj = j + ( ilocblk - nblocks ) * nb
2198 ELSE
2199 jj = inb + ( ilocblk - 1 ) * nb + 1
2200 END IF
2201 ELSE
2202 jj = inb + ilocblk * nb + 1
2203 END IF
2204 ELSE
2205 jj = inb + 1
2206 END IF
2207*
2208 ELSE
2209*
2210 j1 = j - inb
2211 nblocks = ( j1 - 1 ) / nb + 1
2212 pcol = pcol + nblocks
2213 pcol = pcol - ( pcol / npcol ) * npcol
2214*
2215 mydist = mycol - csrc
2216 IF( mydist.LT.0 )
2217 $ mydist = mydist + npcol
2218*
2219 ilocblk = nblocks / npcol
2220*
2221 IF( ilocblk.GT.0 ) THEN
2222 mydist = mydist - nblocks + ilocblk * npcol
2223 IF( mydist.LT.0 ) THEN
2224 jj = nb + ilocblk * nb + 1
2225 ELSE
2226 IF( mycol.EQ.pcol ) THEN
2227 jj = j1 + ( ilocblk - nblocks + 1 ) * nb
2228 ELSE
2229 jj = ilocblk * nb + 1
2230 END IF
2231 END IF
2232 ELSE
2233 mydist = mydist - nblocks
2234 IF( mydist.LT.0 ) THEN
2235 jj = nb + 1
2236 ELSE IF( mycol.EQ.pcol ) THEN
2237 jj = j1 + ( 1 - nblocks ) * nb
2238 ELSE
2239 jj = 1
2240 END IF
2241 END IF
2242 END IF
2243*
2244 END IF
2245*
2246 RETURN
2247*
2248* End of PB_INFOG2L
2249*

◆ pb_initjmp()

subroutine pb_initjmp ( logical colmaj,
integer nvir,
integer imbvir,
integer inbvir,
integer imbloc,
integer inbloc,
integer mb,
integer nb,
integer rsrc,
integer csrc,
integer nprow,
integer npcol,
integer stride,
integer, dimension( * ) jmp )

Definition at line 4637 of file pblastim.f.

4640*
4641* -- PBLAS test routine (version 2.0) --
4642* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4643* and University of California, Berkeley.
4644* April 1, 1998
4645*
4646* .. Scalar Arguments ..
4647 LOGICAL COLMAJ
4648 INTEGER CSRC, IMBLOC, IMBVIR, INBLOC, INBVIR, MB, NB,
4649 $ NPCOL, NPROW, NVIR, RSRC, STRIDE
4650* ..
4651* .. Array Arguments ..
4652 INTEGER JMP( * )
4653* ..
4654*
4655* Purpose
4656* =======
4657*
4658* PB_INITJMP initializes the jump values JMP used by the random matrix
4659* generator.
4660*
4661* Arguments
4662* =========
4663*
4664* COLMAJ (global input) LOGICAL
4665* On entry, COLMAJ specifies the ordering of the random sequen-
4666* ce. When COLMAJ is .TRUE., the random sequence will be used
4667* for a column major ordering, and otherwise a row-major orde-
4668* ring. This impacts on the computation of the jump values.
4669*
4670* NVIR (global input) INTEGER
4671* On entry, NVIR specifies the size of the underlying virtual
4672* matrix. NVIR must be at least zero.
4673*
4674* IMBVIR (local input) INTEGER
4675* On entry, IMBVIR specifies the number of virtual rows of the
4676* upper left block of the underlying virtual submatrix. IMBVIR
4677* must be at least IMBLOC.
4678*
4679* INBVIR (local input) INTEGER
4680* On entry, INBVIR specifies the number of virtual columns of
4681* the upper left block of the underlying virtual submatrix.
4682* INBVIR must be at least INBLOC.
4683*
4684* IMBLOC (local input) INTEGER
4685* On entry, IMBLOC specifies the number of rows (size) of the
4686* local uppest blocks. IMBLOC is at least zero.
4687*
4688* INBLOC (local input) INTEGER
4689* On entry, INBLOC specifies the number of columns (size) of
4690* the local leftmost blocks. INBLOC is at least zero.
4691*
4692* MB (global input) INTEGER
4693* On entry, MB specifies the size of the blocks used to parti-
4694* tion the matrix rows. MB must be at least one.
4695*
4696* NB (global input) INTEGER
4697* On entry, NB specifies the size of the blocks used to parti-
4698* tion the matrix columns. NB must be at least one.
4699*
4700* RSRC (global input) INTEGER
4701* On entry, RSRC specifies the row coordinate of the process
4702* that possesses the first row of the matrix. When RSRC = -1,
4703* the rows are not distributed but replicated, otherwise RSRC
4704* must be at least zero and strictly less than NPROW.
4705*
4706* CSRC (global input) INTEGER
4707* On entry, CSRC specifies the column coordinate of the pro-
4708* cess that possesses the first column of the matrix. When CSRC
4709* is equal to -1, the columns are not distributed but replica-
4710* ted, otherwise CSRC must be at least zero and strictly less
4711* than NPCOL.
4712*
4713* NPROW (global input) INTEGER
4714* On entry, NPROW specifies the total number of process rows
4715* over which the matrix is distributed. NPROW must be at least
4716* one.
4717*
4718* NPCOL (global input) INTEGER
4719* On entry, NPCOL specifies the total number of process co-
4720* lumns over which the matrix is distributed. NPCOL must be at
4721* least one.
4722*
4723* STRIDE (global input) INTEGER
4724* On entry, STRIDE specifies the number of random numbers to be
4725* generated to compute one matrix entry. In the real case,
4726* STRIDE is usually 1, where as in the complex case STRIDE is
4727* usually 2 in order to generate the real and imaginary parts.
4728*
4729* JMP (local output) INTEGER array
4730* On entry, JMP is an array of dimension JMP_LEN. On exit, this
4731* array contains the different jump values used by the random
4732* matrix generator.
4733*
4734* -- Written on April 1, 1998 by
4735* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4736*
4737* =====================================================================
4738*
4739* .. Parameters ..
4740 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4741 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4742 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4743 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
4744 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
4745 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
4746 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
4747 $ jmp_len = 11 )
4748* ..
4749* .. Local Scalars ..
4750 INTEGER NPMB, NQNB
4751* ..
4752* .. Executable Statements ..
4753*
4754 IF( rsrc.LT.0 ) THEN
4755 npmb = mb
4756 ELSE
4757 npmb = nprow * mb
4758 END IF
4759 IF( csrc.LT.0 ) THEN
4760 nqnb = nb
4761 ELSE
4762 nqnb = npcol * nb
4763 END IF
4764*
4765 jmp( jmp_1 ) = 1
4766*
4767 jmp( jmp_mb ) = mb
4768 jmp( jmp_imbv ) = imbvir
4769 jmp( jmp_npmb ) = npmb
4770 jmp( jmp_npimbloc ) = imbloc + npmb - mb
4771*
4772 jmp( jmp_nb ) = nb
4773 jmp( jmp_inbv ) = inbvir
4774 jmp( jmp_nqnb ) = nqnb
4775 jmp( jmp_nqinbloc ) = inbloc + nqnb - nb
4776*
4777 IF( colmaj ) THEN
4778 jmp( jmp_row ) = stride
4779 jmp( jmp_col ) = stride * nvir
4780 ELSE
4781 jmp( jmp_row ) = stride * nvir
4782 jmp( jmp_col ) = stride
4783 END IF
4784*
4785 RETURN
4786*
4787* End of PB_INITJMP
4788*

◆ pb_initmuladd()

subroutine pb_initmuladd ( integer, dimension( * ) muladd0,
integer, dimension( * ) jmp,
integer, dimension( 4, * ) imuladd )

Definition at line 4790 of file pblastim.f.

4791*
4792* -- PBLAS test routine (version 2.0) --
4793* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4794* and University of California, Berkeley.
4795* April 1, 1998
4796*
4797* .. Array Arguments ..
4798 INTEGER IMULADD( 4, * ), JMP( * ), MULADD0( * )
4799* ..
4800*
4801* Purpose
4802* =======
4803*
4804* PB_INITMULADD initializes the constants a's and c's corresponding to
4805* the jump values (JMP) used by the matrix generator.
4806*
4807* Arguments
4808* =========
4809*
4810* MULADD0 (local input) INTEGER array
4811* On entry, MULADD0 is an array of dimension 4 containing the
4812* encoded initial constants a and c to jump from X( n ) to
4813* X( n+1 ) = a*X( n ) + c in the random sequence. MULADD0(1:2)
4814* contains respectively the 16-lower and 16-higher bits of the
4815* constant a, and MULADD0(3:4) contains the 16-lower and
4816* 16-higher bits of the constant c.
4817*
4818* JMP (local input) INTEGER array
4819* On entry, JMP is an array of dimension JMP_LEN containing the
4820* different jump values used by the matrix generator.
4821*
4822* IMULADD (local output) INTEGER array
4823* On entry, IMULADD is an array of dimension ( 4, JMP_LEN ). On
4824* exit, the jth column of this array contains the encoded ini-
4825* tial constants a_j and c_j to jump from X( n ) to X(n+JMP(j))
4826* (= a_j*X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
4827* contains respectively the 16-lower and 16-higher bits of the
4828* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
4829* 16-higher bits of the constant c_j.
4830*
4831* -- Written on April 1, 1998 by
4832* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4833*
4834* =====================================================================
4835*
4836* .. Parameters ..
4837 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4838 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4839 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4840 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
4841 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
4842 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
4843 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
4844 $ jmp_len = 11 )
4845* ..
4846*
4847* .. Local Arrays ..
4848 INTEGER ITMP1( 2 ), ITMP2( 2 )
4849* ..
4850* .. External Subroutines ..
4851 EXTERNAL pb_jump
4852* ..
4853* .. Executable Statements ..
4854*
4855 itmp2( 1 ) = 100
4856 itmp2( 2 ) = 0
4857*
4858* Compute IMULADD for all JMP values
4859*
4860 CALL pb_jump( jmp( jmp_1 ), muladd0, itmp2, itmp1,
4861 $ imuladd( 1, jmp_1 ) )
4862*
4863 CALL pb_jump( jmp( jmp_row ), muladd0, itmp1, itmp2,
4864 $ imuladd( 1, jmp_row ) )
4865 CALL pb_jump( jmp( jmp_col ), muladd0, itmp1, itmp2,
4866 $ imuladd( 1, jmp_col ) )
4867*
4868* Compute constants a and c to jump JMP( * ) numbers in the
4869* sequence for column- or row-major ordering of the sequence.
4870*
4871 CALL pb_jump( jmp( jmp_imbv ), imuladd( 1, jmp_row ), itmp1,
4872 $ itmp2, imuladd( 1, jmp_imbv ) )
4873 CALL pb_jump( jmp( jmp_mb ), imuladd( 1, jmp_row ), itmp1,
4874 $ itmp2, imuladd( 1, jmp_mb ) )
4875 CALL pb_jump( jmp( jmp_npmb ), imuladd( 1, jmp_row ), itmp1,
4876 $ itmp2, imuladd( 1, jmp_npmb ) )
4877 CALL pb_jump( jmp( jmp_npimbloc ), imuladd( 1, jmp_row ), itmp1,
4878 $ itmp2, imuladd( 1, jmp_npimbloc ) )
4879*
4880 CALL pb_jump( jmp( jmp_inbv ), imuladd( 1, jmp_col ), itmp1,
4881 $ itmp2, imuladd( 1, jmp_inbv ) )
4882 CALL pb_jump( jmp( jmp_nb ), imuladd( 1, jmp_col ), itmp1,
4883 $ itmp2, imuladd( 1, jmp_nb ) )
4884 CALL pb_jump( jmp( jmp_nqnb ), imuladd( 1, jmp_col ), itmp1,
4885 $ itmp2, imuladd( 1, jmp_nqnb ) )
4886 CALL pb_jump( jmp( jmp_nqinbloc ), imuladd( 1, jmp_col ), itmp1,
4887 $ itmp2, imuladd( 1, jmp_nqinbloc ) )
4888*
4889 RETURN
4890*
4891* End of PB_INITMULADD
4892*
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastim.f:5243

◆ pb_inquire()

double precision function pb_inquire ( character*1 tmtype,
integer i )

Definition at line 3128 of file pblastim.f.

3129*
3130* -- PBLAS test routine (version 2.0) --
3131* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3132* and University of California, Berkeley.
3133* April 1, 1998
3134*
3135* .. Scalar Arguments ..
3136 CHARACTER*1 TMTYPE
3137 INTEGER I
3138* ..
3139*
3140* Purpose
3141* =======
3142*
3143* PB_INQUIRE returns wall or cpu time that has accumulated in timer I.
3144*
3145* Arguments
3146* =========
3147*
3148* TMTYPE (global input) CHARACTER
3149* On entry, TMTYPE specifies what time will be returned as fol-
3150* lows
3151* = 'W': wall clock time is returned,
3152* = 'C': CPU time is returned (default).
3153*
3154* I (global input) INTEGER
3155* On entry, I specifies the timer to return.
3156*
3157* -- Written on April 1, 1998 by
3158* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3159*
3160* =====================================================================
3161*
3162* .. Parameters ..
3163 INTEGER NTIMER
3164 parameter( ntimer = 64 )
3165 DOUBLE PRECISION ERRFLAG
3166 parameter( errflag = -1.0d+0 )
3167* ..
3168* .. Local Scalars ..
3169 DOUBLE PRECISION TIME
3170* ..
3171* .. External Functions ..
3172 LOGICAL LSAME
3173 DOUBLE PRECISION DCPUTIME00, DWALLTIME00
3174 EXTERNAL dcputime00, dwalltime00, lsame
3175* ..
3176* .. Common Blocks ..
3177 LOGICAL DISABLED
3178 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3179 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3180 COMMON /sltimer00/ cpusec, wallsec, cpustart, wallstart, disabled
3181* ..
3182* .. Executable Statements ..
3183*
3184 IF( lsame( tmtype, 'W' ) ) THEN
3185*
3186* If walltime not available on this machine, return -1 flag
3187*
3188 IF( dwalltime00().EQ.errflag ) THEN
3189 time = errflag
3190 ELSE
3191 time = wallsec( i )
3192 END IF
3193 ELSE
3194 IF( dcputime00().EQ.errflag ) THEN
3195 time = errflag
3196 ELSE
3197 time = cpusec( i )
3198 END IF
3199 END IF
3200*
3201 pb_inquire = time
3202*
3203 RETURN
3204*
3205* End of PB_INQUIRE
3206*
pb_inquire
double precision function pb_inquire(tmtype, i)
Definition pblastim.f:3129

◆ pb_jump()

subroutine pb_jump ( integer k,
integer, dimension( 4 ) muladd,
integer, dimension( 2 ) irann,
integer, dimension( 2 ) iranm,
integer, dimension( 4 ) ima )

Definition at line 5242 of file pblastim.f.

5243*
5244* -- PBLAS test routine (version 2.0) --
5245* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5246* and University of California, Berkeley.
5247* April 1, 1998
5248*
5249* .. Scalar Arguments ..
5250 INTEGER K
5251* ..
5252* .. Array Arguments ..
5253 INTEGER IMA( 4 ), IRANM( 2 ), IRANN( 2 ), MULADD( 4 )
5254* ..
5255*
5256* Purpose
5257* =======
5258*
5259* PB_JUMP computes the constants A and C to jump K numbers in the ran-
5260* dom sequence:
5261*
5262* X( n+K ) = A * X( n ) + C.
5263*
5264* The constants encoded in MULADD specify how to jump from entry in the
5265* sequence to the next.
5266*
5267* Arguments
5268* =========
5269*
5270* K (local input) INTEGER
5271* On entry, K specifies the number of entries of the sequence
5272* to jump over. When K is less or equal than zero, A and C are
5273* not computed, and IRANM is set to IRANN corresponding to a
5274* jump of size zero.
5275*
5276* MULADD (local input) INTEGER array
5277* On entry, MULADD is an array of dimension 4 containing the
5278* encoded constants a and c to jump from X( n ) to X( n+1 )
5279* ( = a*X( n )+c) in the random sequence. MULADD(1:2) contains
5280* respectively the 16-lower and 16-higher bits of the constant
5281* a, and MULADD(3:4) contains the 16-lower and 16-higher bits
5282* of the constant c.
5283*
5284* IRANN (local input) INTEGER array
5285* On entry, IRANN is an array of dimension 2. This array con-
5286* tains respectively the 16-lower and 16-higher bits of the en-
5287* coding of X( n ).
5288*
5289* IRANM (local output) INTEGER array
5290* On entry, IRANM is an array of dimension 2. On exit, this
5291* array contains respectively the 16-lower and 16-higher bits
5292* of the encoding of X( n+K ).
5293*
5294* IMA (local output) INTEGER array
5295* On entry, IMA is an array of dimension 4. On exit, when K is
5296* greater than zero, this array contains the encoded constants
5297* A and C to jump from X( n ) to X( n+K ) in the random se-
5298* quence. IMA(1:2) contains respectively the 16-lower and
5299* 16-higher bits of the constant A, and IMA(3:4) contains the
5300* 16-lower and 16-higher bits of the constant C. When K is
5301* less or equal than zero, this array is not referenced.
5302*
5303* -- Written on April 1, 1998 by
5304* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5305*
5306* =====================================================================
5307*
5308* .. Local Scalars ..
5309 INTEGER I
5310* ..
5311* .. Local Arrays ..
5312 INTEGER J( 2 )
5313* ..
5314* .. External Subroutines ..
5315 EXTERNAL pb_ladd, pb_lmul
5316* ..
5317* .. Executable Statements ..
5318*
5319 IF( k.GT.0 ) THEN
5320*
5321 ima( 1 ) = muladd( 1 )
5322 ima( 2 ) = muladd( 2 )
5323 ima( 3 ) = muladd( 3 )
5324 ima( 4 ) = muladd( 4 )
5325*
5326 DO 10 i = 1, k - 1
5327*
5328 CALL pb_lmul( ima, muladd, j )
5329*
5330 ima( 1 ) = j( 1 )
5331 ima( 2 ) = j( 2 )
5332*
5333 CALL pb_lmul( ima( 3 ), muladd, j )
5334 CALL pb_ladd( muladd( 3 ), j, ima( 3 ) )
5335*
5336 10 CONTINUE
5337*
5338 CALL pb_lmul( irann, ima, j )
5339 CALL pb_ladd( j, ima( 3 ), iranm )
5340*
5341 ELSE
5342*
5343 iranm( 1 ) = irann( 1 )
5344 iranm( 2 ) = irann( 2 )
5345*
5346 END IF
5347*
5348 RETURN
5349*
5350* End of PB_JUMP
5351*
pb_ladd
subroutine pb_ladd(j, k, i)
Definition pblastim.f:5075
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastim.f:5154

◆ pb_jumpit()

subroutine pb_jumpit ( integer, dimension( 4 ) muladd,
integer, dimension( 2 ) irann,
integer, dimension( 2 ) iranm )

Definition at line 5416 of file pblastim.f.

5417*
5418* -- PBLAS test routine (version 2.0) --
5419* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5420* and University of California, Berkeley.
5421* April 1, 1998
5422*
5423* .. Array Arguments ..
5424 INTEGER IRANM( 2 ), IRANN( 2 ), MULADD( 4 )
5425* ..
5426*
5427* Purpose
5428* =======
5429*
5430* PB_JUMPIT jumps in the random sequence from the number X( n ) enco-
5431* ded in IRANN to the number X( m ) encoded in IRANM using the cons-
5432* tants A and C encoded in MULADD:
5433*
5434* X( m ) = A * X( n ) + C.
5435*
5436* The constants A and C obviously depend on m and n, see the subroutine
5437* PB_JUMP in order to set them up.
5438*
5439* Arguments
5440* =========
5441*
5442* MULADD (local input) INTEGER array
5443* On netry, MULADD is an array of dimension 4. MULADD(1:2) con-
5444* tains respectively the 16-lower and 16-higher bits of the
5445* constant A, and MULADD(3:4) contains the 16-lower and
5446* 16-higher bits of the constant C.
5447*
5448* IRANN (local input) INTEGER array
5449* On entry, IRANN is an array of dimension 2. This array con-
5450* tains respectively the 16-lower and 16-higher bits of the en-
5451* coding of X( n ).
5452*
5453* IRANM (local output) INTEGER array
5454* On entry, IRANM is an array of dimension 2. On exit, this
5455* array contains respectively the 16-lower and 16-higher bits
5456* of the encoding of X( m ).
5457*
5458* -- Written on April 1, 1998 by
5459* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5460*
5461* =====================================================================
5462*
5463* .. Local Arrays ..
5464 INTEGER J( 2 )
5465* ..
5466* .. External Subroutines ..
5467 EXTERNAL pb_ladd, pb_lmul
5468* ..
5469* .. Common Blocks ..
5470 INTEGER IACS( 4 ), IRAND( 2 )
5471 COMMON /rancom/ irand, iacs
5472* ..
5473* .. Save Statements ..
5474 SAVE /rancom/
5475* ..
5476* .. Executable Statements ..
5477*
5478 CALL pb_lmul( irann, muladd, j )
5479 CALL pb_ladd( j, muladd( 3 ), iranm )
5480*
5481 irand( 1 ) = iranm( 1 )
5482 irand( 2 ) = iranm( 2 )
5483*
5484 RETURN
5485*
5486* End of PB_JUMPIT
5487*

◆ pb_ladd()

subroutine pb_ladd ( integer, dimension( 2 ) j,
integer, dimension( 2 ) k,
integer, dimension( 2 ) i )

Definition at line 5074 of file pblastim.f.

5075*
5076* -- PBLAS test routine (version 2.0) --
5077* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5078* and University of California, Berkeley.
5079* April 1, 1998
5080*
5081* .. Array Arguments ..
5082 INTEGER I( 2 ), J( 2 ), K( 2 )
5083* ..
5084*
5085* Purpose
5086* =======
5087*
5088* PB_LADD adds without carry two long positive integers K and J and put
5089* the result into I. The long integers I, J, K are encoded on 31 bits
5090* using an array of 2 integers. The 16-lower bits are stored in the
5091* first entry of each array, the 15-higher bits in the second entry.
5092* For efficiency purposes, the intrisic modulo function is inlined.
5093*
5094* Arguments
5095* =========
5096*
5097* J (local input) INTEGER array
5098* On entry, J is an array of dimension 2 containing the encoded
5099* long integer J.
5100*
5101* K (local input) INTEGER array
5102* On entry, K is an array of dimension 2 containing the encoded
5103* long integer K.
5104*
5105* I (local output) INTEGER array
5106* On entry, I is an array of dimension 2. On exit, this array
5107* contains the encoded long integer I.
5108*
5109* Further Details
5110* ===============
5111*
5112* K( 2 ) K( 1 )
5113* 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 )
5114* + carry = ( K( 1 ) + J( 1 ) ) / 2**16
5115* J( 2 ) J( 1 )
5116* 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry
5117* ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 )
5118* I( 2 ) I( 1 )
5119* 0XXXXXXX XXXXXXXX I
5120*
5121* -- Written on April 1, 1998 by
5122* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5123*
5124* =====================================================================
5125*
5126* .. Parameters ..
5127 INTEGER IPOW15, IPOW16
5128 parameter( ipow15 = 2**15, ipow16 = 2**16 )
5129* ..
5130* .. Local Scalars ..
5131 INTEGER ITMP1, ITMP2
5132* ..
5133* .. Executable Statements ..
5134*
5135* I( 1 ) = MOD( K( 1 ) + J( 1 ), IPOW16 )
5136*
5137 itmp1 = k( 1 ) + j( 1 )
5138 itmp2 = itmp1 / ipow16
5139 i( 1 ) = itmp1 - itmp2 * ipow16
5140*
5141* I( 2 ) = MOD( ( K( 1 ) + J( 1 ) ) / IPOW16 + K( 2 ) + J( 2 ),
5142* IPOW15 )
5143*
5144 itmp1 = itmp2 + k( 2 ) + j( 2 )
5145 itmp2 = itmp1 / ipow15
5146 i( 2 ) = itmp1 - itmp2 * ipow15
5147*
5148 RETURN
5149*
5150* End of PB_LADD
5151*

◆ pb_lmul()

subroutine pb_lmul ( integer, dimension( 2 ) k,
integer, dimension( 2 ) j,
integer, dimension( 2 ) i )

Definition at line 5153 of file pblastim.f.

5154*
5155* -- PBLAS test routine (version 2.0) --
5156* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5157* and University of California, Berkeley.
5158* April 1, 1998
5159*
5160* .. Array Arguments ..
5161 INTEGER I( 2 ), J( 2 ), K( 2 )
5162* ..
5163*
5164* Purpose
5165* =======
5166*
5167* PB_LMUL multiplies without carry two long positive integers K and J
5168* and put the result into I. The long integers I, J, K are encoded on
5169* 31 bits using an array of 2 integers. The 16-lower bits are stored in
5170* the first entry of each array, the 15-higher bits in the second entry
5171* of each array. For efficiency purposes, the intrisic modulo function
5172* is inlined.
5173*
5174* Arguments
5175* =========
5176*
5177* K (local input) INTEGER array
5178* On entry, K is an array of dimension 2 containing the encoded
5179* long integer K.
5180*
5181* J (local input) INTEGER array
5182* On entry, J is an array of dimension 2 containing the encoded
5183* long integer J.
5184*
5185* I (local output) INTEGER array
5186* On entry, I is an array of dimension 2. On exit, this array
5187* contains the encoded long integer I.
5188*
5189* Further Details
5190* ===============
5191*
5192* K( 2 ) K( 1 )
5193* 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 )
5194* * carry = ( K( 1 ) + J( 1 ) ) / 2**16
5195* J( 2 ) J( 1 )
5196* 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry
5197* ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 )
5198* I( 2 ) I( 1 )
5199* 0XXXXXXX XXXXXXXX I
5200*
5201* -- Written on April 1, 1998 by
5202* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5203*
5204* =====================================================================
5205*
5206* .. Parameters ..
5207 INTEGER IPOW15, IPOW16, IPOW30
5208 parameter( ipow15 = 2**15, ipow16 = 2**16,
5209 $ ipow30 = 2**30 )
5210* ..
5211* .. Local Scalars ..
5212 INTEGER ITMP1, ITMP2
5213* ..
5214* .. Executable Statements ..
5215*
5216 itmp1 = k( 1 ) * j( 1 )
5217 IF( itmp1.LT.0 )
5218 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
5219*
5220* I( 1 ) = MOD( ITMP1, IPOW16 )
5221*
5222 itmp2 = itmp1 / ipow16
5223 i( 1 ) = itmp1 - itmp2 * ipow16
5224*
5225 itmp1 = k( 1 ) * j( 2 ) + k( 2 ) * j( 1 )
5226 IF( itmp1.LT.0 )
5227 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
5228*
5229 itmp1 = itmp2 + itmp1
5230 IF( itmp1.LT.0 )
5231 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
5232*
5233* I( 2 ) = MOD( ITMP1, IPOW15 )
5234*
5235 i( 2 ) = itmp1 - ( itmp1 / ipow15 ) * ipow15
5236*
5237 RETURN
5238*
5239* End of PB_LMUL
5240*

◆ pb_locinfo()

subroutine pb_locinfo ( integer i,
integer inb,
integer nb,
integer myroc,
integer srcproc,
integer nprocs,
integer ilocblk,
integer ilocoff,
integer mydist )

Definition at line 4503 of file pblastim.f.

4505*
4506* -- PBLAS test routine (version 2.0) --
4507* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4508* and University of California, Berkeley.
4509* April 1, 1998
4510*
4511* .. Scalar Arguments ..
4512 INTEGER I, ILOCBLK, ILOCOFF, INB, MYDIST, MYROC, NB,
4513 $ NPROCS, SRCPROC
4514* ..
4515*
4516* Purpose
4517* =======
4518*
4519* PB_LOCINFO computes local information about the beginning of a sub-
4520* matrix starting at the global index I.
4521*
4522* Arguments
4523* =========
4524*
4525* I (global input) INTEGER
4526* On entry, I specifies the global starting index in the ma-
4527* trix. I must be at least one.
4528*
4529* INB (global input) INTEGER
4530* On entry, INB specifies the size of the first block of rows
4531* or columns of the matrix. INB must be at least one.
4532*
4533* NB (global input) INTEGER
4534* On entry, NB specifies the size of the blocks of rows or co-
4535* lumns of the matrix is partitioned into. NB must be at least
4536* one.
4537*
4538* MYROC (local input) INTEGER
4539* On entry, MYROC is the coordinate of the process whose local
4540* information is determined. MYROC is at least zero and
4541* strictly less than NPROCS.
4542*
4543* SRCPROC (global input) INTEGER
4544* On entry, SRCPROC specifies the coordinate of the process
4545* that possesses the first row or column of the matrix. When
4546* SRCPROC = -1, the data is not distributed but replicated,
4547* otherwise SRCPROC must be at least zero and strictly less
4548* than NPROCS.
4549*
4550* NPROCS (global input) INTEGER
4551* On entry, NPROCS specifies the total number of process rows
4552* or columns over which the submatrix is distributed. NPROCS
4553* must be at least one.
4554*
4555* ILOCBLK (local output) INTEGER
4556* On exit, ILOCBLK specifies the local row or column block
4557* coordinate corresponding to the row or column I of the ma-
4558* trix. ILOCBLK must be at least zero.
4559*
4560* ILOCOFF (local output) INTEGER
4561* On exit, ILOCOFF specifies the local row offset in the block
4562* of local coordinate ILOCBLK corresponding to the row or co-
4563* lumn I of the matrix. ILOCOFF must at least zero.
4564*
4565* MYDIST (local output) INTEGER
4566* On exit, MYDIST specifies the relative process coordinate of
4567* the process specified by MYROC to the process owning the row
4568* or column I. MYDIST is at least zero and strictly less than
4569* NPROCS.
4570*
4571* -- Written on April 1, 1998 by
4572* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4573*
4574* =====================================================================
4575*
4576* .. Local Scalars ..
4577 INTEGER ITMP, NBLOCKS, PROC
4578* ..
4579* .. Executable Statements ..
4580*
4581 ilocoff = 0
4582*
4583 IF( srcproc.LT.0 ) THEN
4584*
4585 mydist = 0
4586*
4587 IF( i.LE.inb ) THEN
4588*
4589 ilocblk = 0
4590 ilocoff = i - 1
4591*
4592 ELSE
4593*
4594 itmp = i - inb
4595 nblocks = ( itmp - 1 ) / nb + 1
4596 ilocblk = nblocks
4597 ilocoff = itmp - 1 - ( nblocks - 1 ) * nb
4598*
4599 END IF
4600*
4601 ELSE
4602*
4603 proc = srcproc
4604 mydist = myroc - proc
4605 IF( mydist.LT.0 )
4606 $ mydist = mydist + nprocs
4607*
4608 IF( i.LE.inb ) THEN
4609*
4610 ilocblk = 0
4611 IF( myroc.EQ.proc )
4612 $ ilocoff = i - 1
4613*
4614 ELSE
4615*
4616 itmp = i - inb
4617 nblocks = ( itmp - 1 ) / nb + 1
4618 proc = proc + nblocks
4619 proc = proc - ( proc / nprocs ) * nprocs
4620 ilocblk = nblocks / nprocs
4621*
4622 IF( ( ilocblk*nprocs ).LT.( mydist-nblocks ) )
4623 $ ilocblk = ilocblk + 1
4624*
4625 IF( myroc.EQ.proc )
4626 $ ilocoff = itmp - 1 - ( nblocks - 1 ) * nb
4627*
4628 END IF
4629*
4630 END IF
4631*
4632 RETURN
4633*
4634* End of PB_LOCINFO
4635*

◆ pb_noabort()

integer function pb_noabort ( integer cinfo)

Definition at line 1852 of file pblastim.f.

1853*
1854* -- PBLAS test routine (version 2.0) --
1855* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1856* and University of California, Berkeley.
1857* April 1, 1998
1858*
1859* .. Scalar Arguments ..
1860 INTEGER CINFO
1861* ..
1862*
1863* Purpose
1864* =======
1865*
1866* PB_NOABORT transmits the info parameter of a PBLAS routine to the
1867* tester and tells the PBLAS error handler to avoid aborting on erro-
1868* neous input arguments.
1869*
1870* Notes
1871* =====
1872*
1873* This routine is necessary because of the CRAY C fortran interface
1874* and the fact that the usual PBLAS error handler routine has been
1875* initially written in C.
1876*
1877* -- Written on April 1, 1998 by
1878* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1879*
1880* =====================================================================
1881*
1882* .. Common Blocks ..
1883 INTEGER INFO, NBLOG, NOUT
1884 LOGICAL ABRTFLG
1885 COMMON /infoc/info, nblog
1886 COMMON /pberrorc/nout, abrtflg
1887* ..
1888* .. Executable Statements ..
1889*
1890 info = cinfo
1891 IF( abrtflg ) THEN
1892 pb_noabort = 0
1893 ELSE
1894 pb_noabort = 1
1895 END IF
1896*
1897 RETURN
1898*
1899* End of PB_NOABORT
1900*
pb_noabort
integer function pb_noabort(cinfo)
Definition pblastim.f:1853

◆ pb_numroc()

integer function pb_numroc ( integer n,
integer i,
integer inb,
integer nb,
integer proc,
integer srcproc,
integer nprocs )

Definition at line 2778 of file pblastim.f.

2779*
2780* -- PBLAS test routine (version 2.0) --
2781* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2782* and University of California, Berkeley.
2783* April 1, 1998
2784*
2785* .. Scalar Arguments ..
2786 INTEGER I, INB, N, NB, NPROCS, PROC, SRCPROC
2787* ..
2788*
2789* Purpose
2790* =======
2791*
2792* PB_NUMROC returns the local number of matrix rows/columns process
2793* PROC will get if we give out N rows/columns starting from global in-
2794* dex I.
2795*
2796* Arguments
2797* =========
2798*
2799* N (global input) INTEGER
2800* On entry, N specifies the number of rows/columns being dealt
2801* out. N must be at least zero.
2802*
2803* I (global input) INTEGER
2804* On entry, I specifies the global index of the matrix entry.
2805* I must be at least one.
2806*
2807* INB (global input) INTEGER
2808* On entry, INB specifies the size of the first block of the
2809* global matrix. INB must be at least one.
2810*
2811* NB (global input) INTEGER
2812* On entry, NB specifies the size of the blocks used to parti-
2813* tion the matrix. NB must be at least one.
2814*
2815* PROC (local input) INTEGER
2816* On entry, PROC specifies the coordinate of the process whose
2817* local portion is determined. PROC must be at least zero and
2818* strictly less than NPROCS.
2819*
2820* SRCPROC (global input) INTEGER
2821* On entry, SRCPROC specifies the coordinate of the process
2822* that possesses the first row or column of the matrix. When
2823* SRCPROC = -1, the data is not distributed but replicated,
2824* otherwise SRCPROC must be at least zero and strictly less
2825* than NPROCS.
2826*
2827* NPROCS (global input) INTEGER
2828* On entry, NPROCS specifies the total number of process rows
2829* or columns over which the matrix is distributed. NPROCS must
2830* be at least one.
2831*
2832* -- Written on April 1, 1998 by
2833* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2834*
2835* =====================================================================
2836*
2837* .. Local Scalars ..
2838 INTEGER I1, ILOCBLK, INB1, MYDIST, N1, NBLOCKS,
2839 $ SRCPROC1
2840* ..
2841* .. Executable Statements ..
2842*
2843 IF( ( srcproc.EQ.-1 ).OR.( nprocs.EQ.1 ) ) THEN
2844 pb_numroc = n
2845 RETURN
2846 END IF
2847*
2848* Compute coordinate of process owning I and corresponding INB
2849*
2850 IF( i.LE.inb ) THEN
2851*
2852* I is in range of first block, i.e SRCPROC owns I.
2853*
2854 srcproc1 = srcproc
2855 inb1 = inb - i + 1
2856*
2857 ELSE
2858*
2859* I is not in first block of matrix, figure out who has it
2860*
2861 i1 = i - 1 - inb
2862 nblocks = i1 / nb + 1
2863 srcproc1 = srcproc + nblocks
2864 srcproc1 = srcproc1 - ( srcproc1 / nprocs ) * nprocs
2865 inb1 = nblocks*nb - i1
2866*
2867 END IF
2868*
2869* Now everything is just like I=1. Search now who has N-1, Is N-1
2870* in the first block ?
2871*
2872 IF( n.LE.inb1 ) THEN
2873 IF( proc.EQ.srcproc1 ) THEN
2874 pb_numroc = n
2875 ELSE
2876 pb_numroc = 0
2877 END IF
2878 RETURN
2879 END IF
2880*
2881 n1 = n - inb1
2882 nblocks = n1 / nb + 1
2883*
2884 IF( proc.EQ.srcproc1 ) THEN
2885 ilocblk = nblocks / nprocs
2886 IF( ilocblk.GT.0 ) THEN
2887 IF( ( nblocks - ilocblk * nprocs ).GT.0 ) THEN
2888 pb_numroc = inb1 + ilocblk * nb
2889 ELSE
2890 pb_numroc = n + nb * ( ilocblk - nblocks )
2891 END IF
2892 ELSE
2893 pb_numroc = inb1
2894 END IF
2895 ELSE
2896 mydist = proc - srcproc1
2897 IF( mydist.LT.0 )
2898 $ mydist = mydist + nprocs
2899 ilocblk = nblocks / nprocs
2900 IF( ilocblk.GT.0 ) THEN
2901 mydist = mydist - nblocks + ilocblk * nprocs
2902 IF( mydist.LT.0 ) THEN
2903 pb_numroc = ( ilocblk + 1 ) * nb
2904 ELSE IF( mydist.GT.0 ) THEN
2905 pb_numroc = ilocblk * nb
2906 ELSE
2907 pb_numroc = n1 + nb * ( ilocblk - nblocks + 1 )
2908 END IF
2909 ELSE
2910 mydist = mydist - nblocks
2911 IF( mydist.LT.0 ) THEN
2912 pb_numroc = nb
2913 ELSE IF( mydist.GT.0 ) THEN
2914 pb_numroc = 0
2915 ELSE
2916 pb_numroc = n1 + nb * ( 1 - nblocks )
2917 END IF
2918 END IF
2919 END IF
2920*
2921 RETURN
2922*
2923* End of PB_NUMROC
2924*

◆ pb_setlocran()

subroutine pb_setlocran ( integer seed,
integer ilocblk,
integer jlocblk,
integer ilocoff,
integer jlocoff,
integer myrdist,
integer mycdist,
integer nprow,
integer npcol,
integer, dimension( * ) jmp,
integer, dimension( 4, * ) imuladd,
integer, dimension( * ) iran )

Definition at line 4894 of file pblastim.f.

4897*
4898* -- PBLAS test routine (version 2.0) --
4899* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4900* and University of California, Berkeley.
4901* April 1, 1998
4902*
4903* .. Scalar Arguments ..
4904 INTEGER ILOCBLK, ILOCOFF, JLOCBLK, JLOCOFF, MYCDIST,
4905 $ MYRDIST, NPCOL, NPROW, SEED
4906* ..
4907* .. Array Arguments ..
4908 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
4909* ..
4910*
4911* Purpose
4912* =======
4913*
4914* PB_SETLOCRAN locally initializes the random number generator.
4915*
4916* Arguments
4917* =========
4918*
4919* SEED (global input) INTEGER
4920* On entry, SEED specifies a positive integer used to initiali-
4921* ze the first number in the random sequence used by the matrix
4922* generator. SEED must be at least zero.
4923*
4924* ILOCBLK (local input) INTEGER
4925* On entry, ILOCBLK specifies the local row block coordinate
4926* corresponding to the first row of the submatrix of interest.
4927* ILOCBLK must be at least zero.
4928*
4929* ILOCOFF (local input) INTEGER
4930* On entry, ILOCOFF specifies the local row offset in the block
4931* of local coordinate ILOCBLK corresponding to the first row of
4932* the submatrix of interest. ILOCOFF must at least zero.
4933*
4934* JLOCBLK (local input) INTEGER
4935* On entry, JLOCBLK specifies the local column block coordinate
4936* corresponding to the first column of the submatrix of inte-
4937* rest. JLOCBLK must be at least zero.
4938*
4939* JLOCOFF (local input) INTEGER
4940* On entry, JLOCOFF specifies the local column offset in the
4941* block of local coordinate JLOCBLK corresponding to the first
4942* column of the submatrix of interest. JLOCOFF must be at least
4943* zero.
4944*
4945* MYRDIST (local input) INTEGER
4946* On entry, MYRDIST specifies the relative row process coordi-
4947* nate to the process owning the first row of the submatrix of
4948* interest. MYRDIST must be at least zero and stricly less than
4949* NPROW (see the subroutine PB_LOCINFO).
4950*
4951* MYCDIST (local input) INTEGER
4952* On entry, MYCDIST specifies the relative column process coor-
4953* dinate to the process owning the first column of the subma-
4954* trix of interest. MYCDIST must be at least zero and stricly
4955* less than NPCOL (see the subroutine PB_LOCINFO).
4956*
4957* NPROW (global input) INTEGER
4958* On entry, NPROW specifies the total number of process rows
4959* over which the matrix is distributed. NPROW must be at least
4960* one.
4961*
4962* NPCOL (global input) INTEGER
4963* On entry, NPCOL specifies the total number of process co-
4964* lumns over which the matrix is distributed. NPCOL must be at
4965* least one.
4966*
4967* JMP (local input) INTEGER array
4968* On entry, JMP is an array of dimension JMP_LEN containing the
4969* different jump values used by the matrix generator.
4970*
4971* IMULADD (local input) INTEGER array
4972* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
4973* jth column of this array contains the encoded initial cons-
4974* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
4975* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
4976* contains respectively the 16-lower and 16-higher bits of the
4977* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
4978* 16-higher bits of the constant c_j.
4979*
4980* IRAN (local output) INTEGER array
4981* On entry, IRAN is an array of dimension 2. On exit, IRAN con-
4982* tains respectively the 16-lower and 32-higher bits of the en-
4983* coding of the entry of the random sequence corresponding lo-
4984* cally to the first local array entry to generate.
4985*
4986* -- Written on April 1, 1998 by
4987* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4988*
4989* =====================================================================
4990*
4991* .. Parameters ..
4992 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4993 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4994 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4995 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
4996 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
4997 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
4998 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
4999 $ jmp_len = 11 )
5000* ..
5001* .. Local Arrays ..
5002 INTEGER IMULADDTMP( 4 ), ITMP( 2 )
5003* ..
5004* .. External Subroutines ..
5005 EXTERNAL pb_jump, pb_setran
5006* ..
5007* .. Executable Statements ..
5008*
5009* Compute and set the value of IRAN corresponding to A( IA, JA )
5010*
5011 itmp( 1 ) = seed
5012 itmp( 2 ) = 0
5013*
5014 CALL pb_jump( jmp( jmp_1 ), imuladd( 1, jmp_1 ), itmp, iran,
5015 $ imuladdtmp )
5016*
5017* Jump ILOCBLK blocks of rows + ILOCOFF rows
5018*
5019 CALL pb_jump( ilocoff, imuladd( 1, jmp_row ), iran, itmp,
5020 $ imuladdtmp )
5021 IF( myrdist.GT.0 ) THEN
5022 CALL pb_jump( jmp( jmp_imbv ), imuladd( 1, jmp_row ), itmp,
5023 $ iran, imuladdtmp )
5024 CALL pb_jump( myrdist - 1, imuladd( 1, jmp_mb ), iran,
5025 $ itmp, imuladdtmp )
5026 CALL pb_jump( ilocblk, imuladd( 1, jmp_npmb ), itmp,
5027 $ iran, imuladdtmp )
5028 ELSE
5029 IF( ilocblk.GT.0 ) THEN
5030 CALL pb_jump( jmp( jmp_imbv ), imuladd( 1, jmp_row ), itmp,
5031 $ iran, imuladdtmp )
5032 CALL pb_jump( nprow - 1, imuladd( 1, jmp_mb ), iran,
5033 $ itmp, imuladdtmp )
5034 CALL pb_jump( ilocblk - 1, imuladd( 1, jmp_npmb ), itmp,
5035 $ iran, imuladdtmp )
5036 ELSE
5037 CALL pb_jump( 0, imuladd( 1, jmp_1 ), itmp,
5038 $ iran, imuladdtmp )
5039 END IF
5040 END IF
5041*
5042* Jump JLOCBLK blocks of columns + JLOCOFF columns
5043*
5044 CALL pb_jump( jlocoff, imuladd( 1, jmp_col ), iran, itmp,
5045 $ imuladdtmp )
5046 IF( mycdist.GT.0 ) THEN
5047 CALL pb_jump( jmp( jmp_inbv ), imuladd( 1, jmp_col ), itmp,
5048 $ iran, imuladdtmp )
5049 CALL pb_jump( mycdist - 1, imuladd( 1, jmp_nb ), iran,
5050 $ itmp, imuladdtmp )
5051 CALL pb_jump( jlocblk, imuladd( 1, jmp_nqnb ), itmp,
5052 $ iran, imuladdtmp )
5053 ELSE
5054 IF( jlocblk.GT.0 ) THEN
5055 CALL pb_jump( jmp( jmp_inbv ), imuladd( 1, jmp_col ), itmp,
5056 $ iran, imuladdtmp )
5057 CALL pb_jump( npcol - 1, imuladd( 1, jmp_nb ), iran,
5058 $ itmp, imuladdtmp )
5059 CALL pb_jump( jlocblk - 1, imuladd( 1, jmp_nqnb ), itmp,
5060 $ iran, imuladdtmp )
5061 ELSE
5062 CALL pb_jump( 0, imuladd( 1, jmp_1 ), itmp,
5063 $ iran, imuladdtmp )
5064 END IF
5065 END IF
5066*
5067 CALL pb_setran( iran, imuladd( 1, jmp_1 ) )
5068*
5069 RETURN
5070*
5071* End of PB_SETLOCRAN
5072*
seed
#define seed()
Definition macros.h:43
pb_setran
subroutine pb_setran(iran, iac)
Definition pblastim.f:5354

◆ pb_setran()

subroutine pb_setran ( integer, dimension( 2 ) iran,
integer, dimension( 4 ) iac )

Definition at line 5353 of file pblastim.f.

5354*
5355* -- PBLAS test routine (version 2.0) --
5356* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5357* and University of California, Berkeley.
5358* April 1, 1998
5359*
5360* .. Array Arguments ..
5361 INTEGER IAC( 4 ), IRAN( 2 )
5362* ..
5363*
5364* Purpose
5365* =======
5366*
5367* PB_SETRAN initializes the random generator with the encoding of the
5368* first number X( 1 ) in the sequence, and the constants a and c used
5369* to compute the next element in the sequence:
5370*
5371* X( n+1 ) = a * X( n ) + c.
5372*
5373* X( 1 ), a and c are stored in the common block RANCOM for later use
5374* (see the routines PB_SRAN or PB_DRAN).
5375*
5376* Arguments
5377* =========
5378*
5379* IRAN (local input) INTEGER array
5380* On entry, IRAN is an array of dimension 2. This array con-
5381* tains respectively the 16-lower and 16-higher bits of the en-
5382* coding of X( 1 ).
5383*
5384* IAC (local input) INTEGER array
5385* On entry, IAC is an array of dimension 4. IAC(1:2) contain
5386* respectively the 16-lower and 16-higher bits of the constant
5387* a, and IAC(3:4) contain the 16-lower and 16-higher bits of
5388* the constant c.
5389*
5390* -- Written on April 1, 1998 by
5391* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5392*
5393* =====================================================================
5394*
5395* .. Common Blocks ..
5396 INTEGER IACS( 4 ), IRAND( 2 )
5397 COMMON /rancom/ irand, iacs
5398* ..
5399* .. Save Statements ..
5400 SAVE /rancom/
5401* ..
5402* .. Executable Statements ..
5403*
5404 irand( 1 ) = iran( 1 )
5405 irand( 2 ) = iran( 2 )
5406 iacs( 1 ) = iac( 1 )
5407 iacs( 2 ) = iac( 2 )
5408 iacs( 3 ) = iac( 3 )
5409 iacs( 4 ) = iac( 4 )
5410*
5411 RETURN
5412*
5413* End of PB_SETRAN
5414*

◆ pb_timer()

subroutine pb_timer ( integer i)

Definition at line 2975 of file pblastim.f.

2976*
2977* -- PBLAS test routine (version 2.0) --
2978* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2979* and University of California, Berkeley.
2980* April 1, 1998
2981*
2982* .. Scalar Arguments ..
2983 INTEGER I
2984* ..
2985*
2986* Purpose
2987* =======
2988*
2989* PB_TIMER provides a "stopwatch" functionality cpu/wall timer in se-
2990* conds. Up to 64 separate timers can be functioning at once. The first
2991* call starts the timer, and the second stops it. This routine can be
2992* disenabled, so that calls to the timer are ignored. This feature can
2993* be used to make sure certain sections of code do not affect timings,
2994* even if they call routines which have PB_TIMER calls in them.
2995*
2996* Arguments
2997* =========
2998*
2999* I (global input) INTEGER
3000* On entry, I specifies the timer to stop/start.
3001*
3002* -- Written on April 1, 1998 by
3003* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3004*
3005* =====================================================================
3006*
3007* .. Parameters ..
3008 INTEGER NTIMER
3009 parameter( ntimer = 64 )
3010 DOUBLE PRECISION STARTFLAG
3011 parameter( startflag = -5.0d+0 )
3012* ..
3013* .. External Functions ..
3014 DOUBLE PRECISION DCPUTIME00, DWALLTIME00
3015 EXTERNAL dcputime00, dwalltime00
3016* ..
3017* .. Common Blocks ..
3018 LOGICAL DISABLED
3019 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3020 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3021 COMMON /sltimer00/ cpusec, wallsec, cpustart, wallstart, disabled
3022* ..
3023* .. Executable Statements ..
3024*
3025* If timing disabled, return
3026*
3027 IF( disabled )
3028 $ RETURN
3029*
3030 IF( wallstart( i ).EQ.startflag ) THEN
3031*
3032* If timer has not been started, start it
3033*
3034 wallstart( i ) = dwalltime00()
3035 cpustart( i ) = dcputime00()
3036*
3037 ELSE
3038*
3039* Stop timer and add interval to count
3040*
3041 cpusec( i ) = cpusec( i ) + dcputime00() - cpustart( i )
3042 wallsec( i ) = wallsec( i ) + dwalltime00() - wallstart( i )
3043 wallstart( i ) = startflag
3044*
3045 END IF
3046*
3047 RETURN
3048*
3049* End of PB_TIMER
3050*

◆ pdopbl2()

double precision function pdopbl2 ( character*7 subnam,
integer m,
integer n,
integer kkl,
integer kku )

Definition at line 1083 of file pblastim.f.

1084*
1085* -- PBLAS test routine (version 2.0) --
1086* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1087* and University of California, Berkeley.
1088* April 1, 1998
1089*
1090* .. Scalar Arguments ..
1091 CHARACTER*7 SUBNAM
1092 INTEGER KKL, KKU, M, N
1093* ..
1094*
1095* Purpose
1096* =======
1097*
1098* PDOPBL2 computes an approximation of the number of floating point
1099* operations performed by a subroutine SUBNAM with the given values of
1100* the parameters M, N, KL, and KU.
1101*
1102* This version counts operations for the Level 2 PBLAS.
1103*
1104* Arguments
1105* =========
1106*
1107* SUBNAM (input) CHARACTER*7
1108* On entry, SUBNAM specifies the name of the subroutine.
1109*
1110* M (input) INTEGER
1111* On entry, M specifies the number of rows of the coefficient
1112* matrix. M must be at least zero.
1113*
1114* N (input) INTEGER
1115* On entry, N specifies the number of columns of the coeffi-
1116* cient matrix. If the matrix is square (such as in a solve
1117* routine) then N is the number of right hand sides. N must be
1118* at least zero.
1119*
1120* KKL (input) INTEGER
1121* On entry, KKL specifies the lower band width of the coeffi-
1122* cient matrix. KL is set to max( 0, min( M-1, KKL ) ).
1123*
1124* KKU (input) INTEGER
1125* On entry, KKU specifies the upper band width of the coeffi-
1126* cient matrix. KU is set to max( 0, min( N-1, KKU ) ).
1127*
1128* -- Written on April 1, 1998 by
1129* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1130*
1131* =====================================================================
1132*
1133* .. Parameters ..
1134 DOUBLE PRECISION ONE, SIX, TWO, ZERO
1135 parameter( one = 1.0d+0, six = 6.0d+0, two = 2.0d+0,
1136 $ zero = 0.0d+0 )
1137* ..
1138* .. Local Scalars ..
1139 CHARACTER*1 C1
1140 CHARACTER*2 C2
1141 CHARACTER*3 C3
1142 DOUBLE PRECISION ADDS, EK, EM, EN, KL, KU, MULTS
1143* ..
1144* .. External Functions ..
1145 LOGICAL LSAME, LSAMEN
1146 EXTERNAL lsame, lsamen
1147* ..
1148* .. Intrinsic Functions ..
1149 INTRINSIC dble, max, min
1150* ..
1151* .. Executable Statements ..
1152*
1153* Quick return if possible
1154*
1155 IF( m.LE.0 .OR. .NOT.( lsamen( 2, subnam, 'PS' ) .OR.
1156 $ lsamen( 2, subnam, 'PD' ) .OR.
1157 $ lsamen( 2, subnam, 'PC' ) .OR. lsamen( 2, subnam, 'PZ' ) ) )
1158 $ THEN
1159 pdopbl2 = zero
1160 RETURN
1161 END IF
1162*
1163 c1 = subnam( 2: 2 )
1164 c2 = subnam( 3: 4 )
1165 c3 = subnam( 5: 7 )
1166 mults = zero
1167 adds = zero
1168 kl = max( 0, min( m-1, kkl ) )
1169 ku = max( 0, min( n-1, kku ) )
1170 em = dble( m )
1171 en = dble( n )
1172 ek = dble( kl )
1173*
1174* -------------------------------
1175* Matrix-vector multiply routines
1176* -------------------------------
1177*
1178 IF( lsamen( 3, c3, 'MV ' ) ) THEN
1179*
1180 IF( lsamen( 2, c2, 'GE' ) ) THEN
1181*
1182 mults = em * ( en + one )
1183 adds = em * en
1184*
1185* Assume M <= N + KL and KL < M
1186* N <= M + KU and KU < N
1187* so that the zero sections are triangles.
1188*
1189 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
1190*
1191 mults = em * ( en + one ) -
1192 $ ( em - one - kl ) * ( em - kl ) / two -
1193 $ ( en - one - ku ) * ( en - ku ) / two
1194 adds = em * ( en + one ) -
1195 $ ( em - one - kl ) * ( em - kl ) / two -
1196 $ ( en - one - ku ) * ( en - ku ) / two
1197*
1198 ELSE IF( lsamen( 2, c2, 'SY' ) .OR. lsamen( 2, c2, 'SP' ) .OR.
1199 $ lsamen( 2, c2, 'HE' ) .OR. lsamen( 2, c2, 'HP' ) )
1200 $ THEN
1201*
1202 mults = em * ( em + one )
1203 adds = em * em
1204*
1205 ELSE IF( lsamen( 2, c2, 'SB' ) .OR.
1206 $ lsamen( 2, c2, 'HB' ) ) THEN
1207*
1208 mults = em * ( em + one ) - ( em - one - ek ) * ( em - ek )
1209 adds = em * em - ( em - one - ek ) * ( em - ek )
1210*
1211 ELSE IF( lsamen( 2, c2, 'TR' ) .OR. lsamen( 2, c2, 'TP' ) )
1212 $ THEN
1213*
1214 mults = em * ( em + one ) / two
1215 adds = ( em - one ) * em / two
1216*
1217 ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
1218*
1219 mults = em * ( em + one ) / two -
1220 $ ( em - ek - one ) * ( em - ek ) / two
1221 adds = ( em - one ) * em / two -
1222 $ ( em - ek - one ) * ( em - ek ) / two
1223*
1224 END IF
1225*
1226* ---------------------
1227* Matrix solve routines
1228* ---------------------
1229*
1230 ELSE IF( lsamen( 3, c3, 'SV ' ) ) THEN
1231*
1232 IF( lsamen( 2, c2, 'TR' ) .OR. lsamen( 2, c2, 'TP' ) ) THEN
1233*
1234 mults = em * ( em + one ) / two
1235 adds = ( em - one ) * em / two
1236*
1237 ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
1238*
1239 mults = em * ( em + one ) / two -
1240 $ ( em - ek - one ) * ( em - ek ) / two
1241 adds = ( em - one ) * em / two -
1242 $ ( em - ek - one ) * ( em - ek ) / two
1243*
1244 END IF
1245*
1246* ----------------
1247* Rank-one updates
1248* ----------------
1249*
1250 ELSE IF( lsamen( 3, c3, 'R ' ) ) THEN
1251*
1252 IF( lsamen( 2, c2, 'GE' ) ) THEN
1253*
1254 mults = em * en + min( em, en )
1255 adds = em * en
1256*
1257 ELSE IF( lsamen( 2, c2, 'SY' ) .OR. lsamen( 2, c2, 'SP' ) .OR.
1258 $ lsamen( 2, c2, 'HE' ) .OR. lsamen( 2, c2, 'HP' ) )
1259 $ THEN
1260*
1261 mults = em * ( em + one ) / two + em
1262 adds = em * ( em + one ) / two
1263*
1264 END IF
1265*
1266 ELSE IF( lsamen( 3, c3, 'RC ' ) .OR. lsamen( 3, c3, 'RU ' ) ) THEN
1267*
1268 IF( lsamen( 2, c2, 'GE' ) ) THEN
1269*
1270 mults = em * en + min( em, en )
1271 adds = em * en
1272*
1273 END IF
1274*
1275* ----------------
1276* Rank-two updates
1277* ----------------
1278*
1279 ELSE IF( lsamen( 3, c3, 'R2 ' ) ) THEN
1280 IF( lsamen( 2, c2, 'SY' ) .OR. lsamen( 2, c2, 'SP' ) .OR.
1281 $ lsamen( 2, c2, 'HE' ) .OR. lsamen( 2, c2, 'HP' ) ) THEN
1282*
1283 mults = em * ( em + one ) + two * em
1284 adds = em * ( em + one )
1285*
1286 END IF
1287 END IF
1288*
1289* ------------------------------------------------
1290* Compute the total number of operations.
1291* For real and double precision routines, count
1292* 1 for each multiply and 1 for each add.
1293* For complex and complex*16 routines, count
1294* 6 for each multiply and 2 for each add.
1295* ------------------------------------------------
1296*
1297 IF( lsame( c1, 'S' ) .OR. lsame( c1, 'D' ) ) THEN
1298*
1299 pdopbl2 = mults + adds
1300*
1301 ELSE
1302*
1303 pdopbl2 = six * mults + two * adds
1304*
1305 END IF
1306*
1307 RETURN
1308*
1309* End of PDOPBL2
1310*
pdopbl2
double precision function pdopbl2(subnam, m, n, kkl, kku)
Definition pblastim.f:1084

◆ pdopbl3()

double precision function pdopbl3 ( character*7 subnam,
integer m,
integer n,
integer k )

Definition at line 1312 of file pblastim.f.

1313*
1314* -- PBLAS test routine (version 2.0) --
1315* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1316* and University of California, Berkeley.
1317* April 1, 1998
1318*
1319* .. Scalar Arguments ..
1320 CHARACTER*7 SUBNAM
1321 INTEGER K, M, N
1322* ..
1323*
1324* Purpose
1325* =======
1326*
1327* PDOPBL3 computes an approximation of the number of floating point
1328* operations performed by a subroutine SUBNAM with the given values of
1329* the parameters M, N and K.
1330*
1331* This version counts operations for the Level 3 PBLAS.
1332*
1333* Arguments
1334* =========
1335*
1336* SUBNAM (input) CHARACTER*7
1337* On entry, SUBNAM specifies the name of the subroutine.
1338*
1339* M (input) INTEGER
1340* N (input) INTEGER
1341* K (input) INTEGER
1342* On entry, M, N, and K contain parameter values used by the
1343* Level 3 PBLAS. The output matrix is always M x N or N x N if
1344* symmetric, but K has different uses in different contexts.
1345* For example, in the matrix-matrix multiply routine, we have
1346* C = A * B where C is M x N, A is M x K, and B is K x N. In
1347* PxSYMM, PxHEMM, PxTRMM, and PxTRSM, K indicates whether the
1348* matrix A is applied on the left or right. If K <= 0, the ma-
1349* trix is applied on the left, and if K > 0, on the right. In
1350* PxTRADD, K indicates whether the matrix C is upper or lower
1351* triangular. If K <= 0, the matrix C is upper triangular, and
1352* lower triangular otherwise.
1353*
1354* -- Written on April 1, 1998 by
1355* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1356*
1357* =====================================================================
1358*
1359* .. Parameters ..
1360 DOUBLE PRECISION ONE, SIX, TWO, ZERO
1361 parameter( one = 1.0d+0, six = 6.0d+0, two = 2.0d+0,
1362 $ zero = 0.0d+0 )
1363* ..
1364* .. Local Scalars ..
1365 CHARACTER*1 C1
1366 CHARACTER*2 C2
1367 CHARACTER*3 C3
1368 DOUBLE PRECISION ADDS, EK, EM, EN, MULTS
1369* ..
1370* .. External Functions ..
1371 LOGICAL LSAME, LSAMEN
1372 EXTERNAL lsame, lsamen
1373* ..
1374* .. Intrinsic Functions ..
1375 INTRINSIC dble
1376* ..
1377* .. Executable Statements ..
1378*
1379* Quick return if possible
1380*
1381 IF( m.LE.0 .OR. .NOT.( lsamen( 2, subnam, 'PS' ) .OR.
1382 $ lsamen( 2, subnam, 'PD' ) .OR. lsamen( 2, subnam, 'PC' )
1383 $ .OR. lsamen( 2, subnam, 'PZ' ) ) )
1384 $ THEN
1385 pdopbl3 = zero
1386 RETURN
1387 END IF
1388*
1389 c1 = subnam( 2: 2 )
1390 c2 = subnam( 3: 4 )
1391 c3 = subnam( 5: 7 )
1392 mults = zero
1393 adds = zero
1394 em = dble( m )
1395 en = dble( n )
1396 ek = dble( k )
1397*
1398* ----------------------
1399* Matrix-matrix products
1400* assume beta = 1
1401* ----------------------
1402*
1403 IF( lsamen( 3, c3, 'MM ' ) ) THEN
1404*
1405 IF( lsamen( 2, c2, 'GE' ) ) THEN
1406*
1407 mults = em * ek * en
1408 adds = em * ek * en
1409*
1410 ELSE IF( lsamen( 2, c2, 'SY' ) .OR.
1411 $ lsamen( 2, c2, 'HE' ) ) THEN
1412*
1413* IF K <= 0, assume A multiplies B on the left.
1414*
1415 IF( k.LE.0 ) THEN
1416 mults = em * em * en
1417 adds = em * em * en
1418 ELSE
1419 mults = em * en * en
1420 adds = em * en * en
1421 END IF
1422*
1423 ELSE IF( lsamen( 2, c2, 'TR' ) ) THEN
1424*
1425* IF K <= 0, assume A multiplies B on the left.
1426*
1427 IF( k.LE.0 ) THEN
1428 mults = en * em * ( em + one ) / two
1429 adds = en * em * ( em - one ) / two
1430 ELSE
1431 mults = em * en * ( en + one ) / two
1432 adds = em * en * ( en - one ) / two
1433 END IF
1434*
1435 END IF
1436*
1437* ------------------------------------------------
1438* Rank-K update of a symmetric or Hermitian matrix
1439* ------------------------------------------------
1440*
1441 ELSE IF( lsamen( 3, c3, 'RK ' ) ) THEN
1442*
1443 IF( lsamen( 2, c2, 'SY' ) .OR.
1444 $ lsamen( 2, c2, 'HE' ) ) THEN
1445*
1446 mults = ek * em *( em + one ) / two
1447 adds = ek * em *( em + one ) / two
1448 END IF
1449*
1450* -------------------------------------------------
1451* Rank-2K update of a symmetric or Hermitian matrix
1452* -------------------------------------------------
1453*
1454 ELSE IF( lsamen( 3, c3, 'R2K' ) ) THEN
1455*
1456 IF( lsamen( 2, c2, 'SY' ) .OR.
1457 $ lsamen( 3, c2, 'HE' ) ) THEN
1458*
1459 mults = ek * em * em
1460 adds = ek * em * em + em
1461 END IF
1462*
1463* -----------------------------------------
1464* Solving system with many right hand sides
1465* -----------------------------------------
1466*
1467 ELSE IF( lsamen( 4, subnam( 3:6 ), 'TRSM' ) ) THEN
1468*
1469 IF( k.LE.0 ) THEN
1470 mults = en * em * ( em + one ) / two
1471 adds = en * em * ( em - one ) / two
1472 ELSE
1473 mults = em * en * ( en + one ) / two
1474 adds = em * en * ( en - one ) / two
1475 END IF
1476*
1477* --------------------------
1478* Matrix (tranpose) Addition
1479* --------------------------
1480*
1481 ELSE IF( lsamen( 3, c3, 'ADD' ) ) THEN
1482*
1483 IF( lsamen( 2, c2, 'GE' ) ) THEN
1484*
1485 mults = 2 * em * en
1486 adds = em * en
1487*
1488 ELSE IF( lsamen( 2, c2, 'TR' ) ) THEN
1489*
1490* IF K <= 0, assume C is upper triangular.
1491*
1492 IF( k.LE.0 ) THEN
1493 IF( m.LE.n ) THEN
1494 mults = em * ( two * en - em + one )
1495 adds = em * ( em + one ) / two + em * ( en - em )
1496 ELSE
1497 mults = en * ( en + one )
1498 adds = en * ( en + one ) / two
1499 END IF
1500 ELSE
1501 IF( m.GE.n ) THEN
1502 mults = en * ( two * em - en + one )
1503 adds = en * ( en + one ) / two + en * ( em - en )
1504 ELSE
1505 mults = em * ( em + one )
1506 adds = em * ( em + one ) / two
1507 END IF
1508 END IF
1509*
1510 END IF
1511*
1512 END IF
1513*
1514* ------------------------------------------------
1515* Compute the total number of operations.
1516* For real and double precision routines, count
1517* 1 for each multiply and 1 for each add.
1518* For complex and complex*16 routines, count
1519* 6 for each multiply and 2 for each add.
1520* ------------------------------------------------
1521*
1522 IF( lsame( c1, 'S' ) .OR. lsame( c1, 'D' ) ) THEN
1523*
1524 pdopbl3 = mults + adds
1525*
1526 ELSE
1527*
1528 pdopbl3 = six * mults + two * adds
1529*
1530 END IF
1531*
1532 RETURN
1533*
1534* End of PDOPBL3
1535*
pdopbl3
double precision function pdopbl3(subnam, m, n, k)
Definition pblastim.f:1313

◆ pilaenv()

integer function pilaenv ( integer ictxt,
character*1 prec )

Definition at line 4452 of file pblastim.f.

4453*
4454* -- PBLAS test routine (version 2.0) --
4455* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4456* and University of California, Berkeley.
4457* April 1, 1998
4458*
4459* .. Scalar Arguments ..
4460 INTEGER ICTXT
4461 CHARACTER*1 PREC
4462* ..
4463*
4464* Purpose
4465* =======
4466*
4467* PILAENV returns the logical computational block size to be used by
4468* the PBLAS routines during testing and timing. This is a special ver-
4469* sion to be used only as part of the testing or timing PBLAS programs
4470* for testing different values of logical computational block sizes for
4471* the PBLAS routines. It is called by the PBLAS routines to retrieve a
4472* logical computational block size value.
4473*
4474* Arguments
4475* =========
4476*
4477* ICTXT (local input) INTEGER
4478* On entry, ICTXT specifies the BLACS context handle, indica-
4479* ting the global context of the operation. The context itself
4480* is global, but the value of ICTXT is local.
4481*
4482* PREC (dummy input) CHARACTER*1
4483* On entry, PREC is a dummy argument.
4484*
4485* -- Written on April 1, 1998 by
4486* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4487*
4488* =====================================================================
4489*
4490* .. Common Blocks ..
4491 INTEGER INFO, NBLOG
4492 COMMON /infoc/info, nblog
4493* ..
4494* .. Executable Statements ..
4495*
4496 pilaenv = nblog
4497*
4498 RETURN
4499*
4500* End of PILAENV
4501*
pilaenv
integer function pilaenv(ictxt, prec)
Definition pblastim.f:4453

◆ pmdescchk()

subroutine pmdescchk ( integer ictxt,
integer nout,
character*1 matrix,
integer, dimension( * ) desca,
integer dta,
integer ma,
integer na,
integer imba,
integer inba,
integer mba,
integer nba,
integer rsrca,
integer csrca,
integer mpa,
integer nqa,
integer iprea,
integer imida,
integer iposta,
integer igap,
integer gapmul,
integer info )

Definition at line 742 of file pblastim.f.

746*
747* -- PBLAS test routine (version 2.0) --
748* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
749* and University of California, Berkeley.
750* April 1, 1998
751*
752* .. Scalar Arguments ..
753 CHARACTER*1 MATRIX
754 INTEGER CSRCA, DTA, GAPMUL, ICTXT, IGAP, IMBA, IMIDA,
755 $ INBA, INFO, IPOSTA, IPREA, MA, MBA, MPA, NA,
756 $ NBA, NOUT, NQA, RSRCA
757* ..
758* .. Array Arguments ..
759 INTEGER DESCA( * )
760* ..
761*
762* Purpose
763* =======
764*
765* PMDESCCHK checks the validity of the input test parameters and ini-
766* tializes the descriptor DESCA and the scalar variables MPA, NQA. In
767* case of an invalid parameter, this routine displays error messages
768* and return an non-zero error code in INFO.
769*
770* Notes
771* =====
772*
773* A description vector is associated with each 2D block-cyclicly dis-
774* tributed matrix. This vector stores the information required to
775* establish the mapping between a matrix entry and its corresponding
776* process and memory location.
777*
778* In the following comments, the character _ should be read as
779* "of the distributed matrix". Let A be a generic term for any 2D
780* block cyclicly distributed matrix. Its description vector is DESCA:
781*
782* NOTATION STORED IN EXPLANATION
783* ---------------- --------------- ------------------------------------
784* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
785* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
786* the NPROW x NPCOL BLACS process grid
787* A is distributed over. The context
788* itself is global, but the handle
789* (the integer value) may vary.
790* M_A (global) DESCA( M_ ) The number of rows in the distribu-
791* ted matrix A, M_A >= 0.
792* N_A (global) DESCA( N_ ) The number of columns in the distri-
793* buted matrix A, N_A >= 0.
794* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
795* block of the matrix A, IMB_A > 0.
796* INB_A (global) DESCA( INB_ ) The number of columns of the upper
797* left block of the matrix A,
798* INB_A > 0.
799* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
800* bute the last M_A-IMB_A rows of A,
801* MB_A > 0.
802* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
803* bute the last N_A-INB_A columns of
804* A, NB_A > 0.
805* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
806* row of the matrix A is distributed,
807* NPROW > RSRC_A >= 0.
808* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
809* first column of A is distributed.
810* NPCOL > CSRC_A >= 0.
811* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
812* array storing the local blocks of
813* the distributed matrix A,
814* IF( Lc( 1, N_A ) > 0 )
815* LLD_A >= MAX( 1, Lr( 1, M_A ) )
816* ELSE
817* LLD_A >= 1.
818*
819* Let K be the number of rows of a matrix A starting at the global in-
820* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
821* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
822* receive if these K rows were distributed over NPROW processes. If K
823* is the number of columns of a matrix A starting at the global index
824* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
825* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
826* these K columns were distributed over NPCOL processes.
827*
828* The values of Lr() and Lc() may be determined via a call to the func-
829* tion PB_NUMROC:
830* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
831* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
832*
833* Arguments
834* =========
835*
836* ICTXT (local input) INTEGER
837* On entry, ICTXT specifies the BLACS context handle, indica-
838* ting the global context of the operation. The context itself
839* is global, but the value of ICTXT is local.
840*
841* NOUT (global input) INTEGER
842* On entry, NOUT specifies the unit number for the output file.
843* When NOUT is 6, output to screen, when NOUT is 0, output to
844* stderr. NOUT is only defined for process 0.
845*
846* MATRIX (global input) CHARACTER*1
847* On entry, MATRIX specifies the one character matrix identi-
848* fier.
849*
850* DESCA (global output) INTEGER array
851* On entry, DESCA is an array of dimension DLEN_. DESCA is the
852* array descriptor to be set.
853*
854* DTYPEA (global input) INTEGER
855* On entry, DTYPEA specifies the descriptor type. In this ver-
856* sion, DTYPEA must be BLOCK_CYCLIC_INB_2D.
857*
858* MA (global input) INTEGER
859* On entry, MA specifies the number of rows in the matrix. MA
860* must be at least zero.
861*
862* NA (global input) INTEGER
863* On entry, NA specifies the number of columns in the matrix.
864* NA must be at least zero.
865*
866* IMBA (global input) INTEGER
867* On entry, IMBA specifies the row blocking factor used to dis-
868* tribute the first IMBA rows of the matrix. IMBA must be at
869* least one.
870*
871* INBA (global input) INTEGER
872* On entry, INBA specifies the column blocking factor used to
873* distribute the first INBA columns of the matrix. INBA must
874* be at least one.
875*
876* MBA (global input) INTEGER
877* On entry, MBA specifies the row blocking factor used to dis-
878* tribute the rows of the matrix. MBA must be at least one.
879*
880* NBA (global input) INTEGER
881* On entry, NBA specifies the column blocking factor used to
882* distribute the columns of the matrix. NBA must be at least
883* one.
884*
885* RSRCA (global input) INTEGER
886* On entry, RSRCA specifies the process row in which the first
887* row of the matrix resides. When RSRCA is -1, the matrix is
888* row replicated, otherwise RSCRA must be at least zero and
889* strictly less than NPROW.
890*
891* CSRCA (global input) INTEGER
892* On entry, CSRCA specifies the process column in which the
893* first column of the matrix resides. When CSRCA is -1, the
894* matrix is column replicated, otherwise CSCRA must be at least
895* zero and strictly less than NPCOL.
896*
897* MPA (local output) INTEGER
898* On exit, MPA is Lr( 1, MA ).
899*
900* NQA (local output) INTEGER
901* On exit, NQA is Lc( 1, NA ).
902*
903* IPREA (local output) INTEGER
904* On exit, IPREA specifies the size of the guard zone to put
905* before the start of the local padded array.
906*
907* IMIDA (local output) INTEGER
908* On exit, IMIDA specifies the lda-gap of the guard zone to
909* put after each column of the local padded array.
910*
911* IPOSTA (local output) INTEGER
912* On exit, IPOSTA specifies the size of the guard zone to put
913* after the local padded array.
914*
915* IGAP (global input) INTEGER
916* On entry, IGAP specifies the size of the lda-gap.
917*
918* GAPMUL (global input) INTEGER
919* On entry, GAPMUL is a constant factor controlling the size
920* of the pre- and post guardzone.
921*
922* INFO (global output) INTEGER
923* On exit, when INFO is zero, no error has been detected,
924* otherwise an error has been detected.
925*
926* -- Written on April 1, 1998 by
927* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
928*
929* =====================================================================
930*
931* .. Parameters ..
932 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
933 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
934 $ RSRC_
935 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
936 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
937 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
938 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
939* ..
940* .. Local Scalars ..
941 INTEGER LLDA, MYCOL, MYROW, NPCOL, NPROW
942* ..
943* .. External Subroutines ..
944 EXTERNAL blacs_gridinfo, igsum2d, pb_descinit2
945* ..
946* .. External Functions ..
947 INTEGER PB_NUMROC
948 EXTERNAL pb_numroc
949* ..
950* .. Intrinsic Functions ..
951 INTRINSIC max
952* ..
953* .. Executable Statements ..
954*
955 info = 0
956 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
957*
958* Verify descriptor type DTYPE_
959*
960 IF( dta.NE.block_cyclic_2d_inb ) THEN
961 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
962 $ WRITE( nout, fmt = 9999 ) matrix, 'DTYPE', matrix, dta,
963 $ block_cyclic_2d_inb
964 info = 1
965 END IF
966*
967* Verify global matrix dimensions (M_,N_) are correct
968*
969 IF( ma.LT.0 ) THEN
970 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
971 $ WRITE( nout, fmt = 9998 ) matrix, 'M', matrix, ma
972 info = 1
973 ELSE IF( na.LT.0 ) THEN
974 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
975 $ WRITE( nout, fmt = 9997 ) matrix, 'N', matrix, na
976 info = 1
977 END IF
978*
979* Verify if blocking factors (IMB_, INB_) are correct
980*
981 IF( imba.LT.1 ) THEN
982 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
983 $ WRITE( nout, fmt = 9996 ) matrix, 'IMB', matrix, imba
984 info = 1
985 ELSE IF( inba.LT.1 ) THEN
986 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
987 $ WRITE( nout, fmt = 9995 ) matrix, 'INB', matrix, inba
988 info = 1
989 END IF
990*
991* Verify if blocking factors (MB_, NB_) are correct
992*
993 IF( mba.LT.1 ) THEN
994 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
995 $ WRITE( nout, fmt = 9994 ) matrix, 'MB', matrix, mba
996 info = 1
997 ELSE IF( nba.LT.1 ) THEN
998 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
999 $ WRITE( nout, fmt = 9993 ) matrix, 'NB', matrix, nba
1000 info = 1
1001 END IF
1002*
1003* Verify if origin process coordinates (RSRC_, CSRC_) are valid
1004*
1005 IF( rsrca.LT.-1 .OR. rsrca.GE.nprow ) THEN
1006 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
1007 WRITE( nout, fmt = 9992 ) matrix
1008 WRITE( nout, fmt = 9990 ) 'RSRC', matrix, rsrca, nprow
1009 END IF
1010 info = 1
1011 ELSE IF( csrca.LT.-1 .OR. csrca.GE.npcol ) THEN
1012 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
1013 WRITE( nout, fmt = 9991 ) matrix
1014 WRITE( nout, fmt = 9990 ) 'CSRC', matrix, csrca, npcol
1015 END IF
1016 info = 1
1017 END IF
1018*
1019* Check all processes for an error
1020*
1021 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
1022*
1023 IF( info.NE.0 ) THEN
1024*
1025 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
1026 WRITE( nout, fmt = 9989 ) matrix
1027 WRITE( nout, fmt = * )
1028 END IF
1029*
1030 ELSE
1031*
1032* Compute local testing leading dimension
1033*
1034 mpa = pb_numroc( ma, 1, imba, mba, myrow, rsrca, nprow )
1035 nqa = pb_numroc( na, 1, inba, nba, mycol, csrca, npcol )
1036 iprea = max( gapmul*nba, mpa )
1037 imida = igap
1038 iposta = max( gapmul*nba, nqa )
1039 llda = max( 1, mpa ) + imida
1040*
1041 CALL pb_descinit2( desca, ma, na, imba, inba, mba, nba, rsrca,
1042 $ csrca, ictxt, llda, info )
1043*
1044* Check all processes for an error
1045*
1046 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
1047*
1048 IF( info.NE.0 ) THEN
1049 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
1050 WRITE( nout, fmt = 9989 ) matrix
1051 WRITE( nout, fmt = * )
1052 END IF
1053 END IF
1054*
1055 END IF
1056*
1057 9999 FORMAT( 2x, '>> Invalid matrix ', a1, ' descriptor type ', a5, a1,
1058 $ ': ', i6, ' should be ', i3, '.' )
1059 9998 FORMAT( 2x, '>> Invalid matrix ', a1, ' row dimension ', a1, a1,
1060 $ ': ', i6, ' should be at least 1.' )
1061 9997 FORMAT( 2x, '>> Invalid matrix ', a1, ' column dimension ', a1,
1062 $ a1, ': ', i6, ' should be at least 1.' )
1063 9996 FORMAT( 2x, '>> Invalid matrix ', a1, ' first row block size ',
1064 $ a3, a1, ': ', i6, ' should be at least 1.' )
1065 9995 FORMAT( 2x, '>> Invalid matrix ', a1, ' first column block size ',
1066 $ a3, a1,': ', i6, ' should be at least 1.' )
1067 9994 FORMAT( 2x, '>> Invalid matrix ', a1, ' row block size ', a2, a1,
1068 $ ': ', i6, ' should be at least 1.' )
1069 9993 FORMAT( 2x, '>> Invalid matrix ', a1, ' column block size ', a2,
1070 $ a1,': ', i6, ' should be at least 1.' )
1071 9992 FORMAT( 2x, '>> Invalid matrix ', a1, ' row process source:' )
1072 9991 FORMAT( 2x, '>> Invalid matrix ', a1, ' column process source:' )
1073 9990 FORMAT( 2x, '>> ', a4, a1, '= ', i6, ' should be >= -1 and < ',
1074 $ i6, '.' )
1075 9989 FORMAT( 2x, '>> Invalid matrix ', a1, ' descriptor: going on to ',
1076 $ 'next test case.' )
1077*
1078 RETURN
1079*
1080* End of PMDESCCHK
1081*
pb_descinit2
subroutine pb_descinit2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld, info)
Definition pblastim.f:3932

◆ pmdimchk()

subroutine pmdimchk ( integer ictxt,
integer nout,
integer m,
integer n,
character*1 matrix,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer info )

Definition at line 200 of file pblastim.f.

202*
203* -- PBLAS test routine (version 2.0) --
204* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
205* and University of California, Berkeley.
206* April 1, 1998
207*
208* .. Scalar Arguments ..
209 CHARACTER*1 MATRIX
210 INTEGER ICTXT, INFO, IA, JA, M, N, NOUT
211* ..
212* .. Array Arguments ..
213 INTEGER DESCA( * )
214* ..
215*
216* Purpose
217* =======
218*
219* PMDIMCHK checks the validity of the input test dimensions. In case of
220* an invalid parameter or discrepancy between the parameters, this rou-
221* tine displays error messages and returns an non-zero error code in
222* INFO.
223*
224* Notes
225* =====
226*
227* A description vector is associated with each 2D block-cyclicly dis-
228* tributed matrix. This vector stores the information required to
229* establish the mapping between a matrix entry and its corresponding
230* process and memory location.
231*
232* In the following comments, the character _ should be read as
233* "of the distributed matrix". Let A be a generic term for any 2D
234* block cyclicly distributed matrix. Its description vector is DESCA:
235*
236* NOTATION STORED IN EXPLANATION
237* ---------------- --------------- ------------------------------------
238* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
239* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
240* the NPROW x NPCOL BLACS process grid
241* A is distributed over. The context
242* itself is global, but the handle
243* (the integer value) may vary.
244* M_A (global) DESCA( M_ ) The number of rows in the distribu-
245* ted matrix A, M_A >= 0.
246* N_A (global) DESCA( N_ ) The number of columns in the distri-
247* buted matrix A, N_A >= 0.
248* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
249* block of the matrix A, IMB_A > 0.
250* INB_A (global) DESCA( INB_ ) The number of columns of the upper
251* left block of the matrix A,
252* INB_A > 0.
253* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
254* bute the last M_A-IMB_A rows of A,
255* MB_A > 0.
256* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
257* bute the last N_A-INB_A columns of
258* A, NB_A > 0.
259* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
260* row of the matrix A is distributed,
261* NPROW > RSRC_A >= 0.
262* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
263* first column of A is distributed.
264* NPCOL > CSRC_A >= 0.
265* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
266* array storing the local blocks of
267* the distributed matrix A,
268* IF( Lc( 1, N_A ) > 0 )
269* LLD_A >= MAX( 1, Lr( 1, M_A ) )
270* ELSE
271* LLD_A >= 1.
272*
273* Let K be the number of rows of a matrix A starting at the global in-
274* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
275* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
276* receive if these K rows were distributed over NPROW processes. If K
277* is the number of columns of a matrix A starting at the global index
278* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
279* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
280* these K columns were distributed over NPCOL processes.
281*
282* The values of Lr() and Lc() may be determined via a call to the func-
283* tion PB_NUMROC:
284* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
285* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
286*
287* Arguments
288* =========
289*
290* ICTXT (local input) INTEGER
291* On entry, ICTXT specifies the BLACS context handle, indica-
292* ting the global context of the operation. The context itself
293* is global, but the value of ICTXT is local.
294*
295* NOUT (global input) INTEGER
296* On entry, NOUT specifies the unit number for the output file.
297* When NOUT is 6, output to screen, when NOUT is 0, output to
298* stderr. NOUT is only defined for process 0.
299*
300* MATRIX (global input) CHARACTER*1
301* On entry, MATRIX specifies the one character matrix identi-
302* fier.
303*
304* IA (global input) INTEGER
305* On entry, IA specifies A's global row index, which points to
306* the beginning of the submatrix sub( A ).
307*
308* JA (global input) INTEGER
309* On entry, JA specifies A's global column index, which points
310* to the beginning of the submatrix sub( A ).
311*
312* DESCA (global and local input) INTEGER array
313* On entry, DESCA is an integer array of dimension DLEN_. This
314* is the array descriptor for the matrix A.
315*
316* INFO (global output) INTEGER
317* On exit, when INFO is zero, no error has been detected,
318* otherwise an error has been detected.
319*
320* -- Written on April 1, 1998 by
321* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
322*
323* =====================================================================
324*
325* .. Parameters ..
326 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
327 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
328 $ RSRC_
329 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
330 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
331 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
332 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
333* ..
334* .. Local Scalars ..
335 INTEGER MYCOL, MYROW, NPCOL, NPROW
336* ..
337* .. External Subroutines ..
338 EXTERNAL blacs_gridinfo, igsum2d
339* ..
340* .. Executable Statements ..
341*
342 info = 0
343 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
344*
345 IF( ( m.LT.0 ).OR.( n.LT.0 ) ) THEN
346 info = 1
347 ELSE IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )THEN
348 IF( desca( m_ ).LT.0 )
349 $ info = 1
350 IF( desca( n_ ).LT.0 )
351 $ info = 1
352 ELSE
353 IF( desca( m_ ).LT.( ia+m-1 ) )
354 $ info = 1
355 IF( desca( n_ ).LT.( ja+n-1 ) )
356 $ info = 1
357 END IF
358*
359* Check all processes for an error
360*
361 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
362*
363 IF( info.NE.0 ) THEN
364 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
365 WRITE( nout, fmt = 9999 ) matrix
366 WRITE( nout, fmt = 9998 ) m, n, matrix, ia, matrix, ja
367 WRITE( nout, fmt = 9997 ) matrix, desca( m_ ), matrix,
368 $ desca( n_ )
369 WRITE( nout, fmt = * )
370 END IF
371 END IF
372*
373 9999 FORMAT( 'Incompatible arguments for matrix ', a1, ':' )
374 9998 FORMAT( 'M = ', i6, ', N = ', i6, ', I', a1, ' = ', i6,
375 $ ', J', a1, ' = ', i6 )
376 9997 FORMAT( 'DESC', a1, '( M_ ) = ', i6, ', DESC', a1, '( N_ ) = ',
377 $ i6, '.' )
378*
379 RETURN
380*
381* End of PMDIMCHK
382*

◆ pvdescchk()

subroutine pvdescchk ( integer ictxt,
integer nout,
character*1 matrix,
integer, dimension( * ) descx,
integer dtx,
integer mx,
integer nx,
integer imbx,
integer inbx,
integer mbx,
integer nbx,
integer rsrcx,
integer csrcx,
integer incx,
integer mpx,
integer nqx,
integer iprex,
integer imidx,
integer ipostx,
integer igap,
integer gapmul,
integer info )

Definition at line 384 of file pblastim.f.

388*
389* -- PBLAS test routine (version 2.0) --
390* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
391* and University of California, Berkeley.
392* April 1, 1998
393*
394* .. Scalar Arguments ..
395 CHARACTER*1 MATRIX
396 INTEGER CSRCX, DTX, GAPMUL, ICTXT, IGAP, IMBX, IMIDX,
397 $ INBX, INCX, INFO, IPOSTX, IPREX, MBX, MPX, MX,
398 $ NBX, NOUT, NQX, NX, RSRCX
399* ..
400* .. Array Arguments ..
401 INTEGER DESCX( * )
402* ..
403*
404* Purpose
405* =======
406*
407* PVDESCCHK checks the validity of the input test parameters and ini-
408* tializes the descriptor DESCX and the scalar variables MPX, NQX. In
409* case of an invalid parameter, this routine displays error messages
410* and return an non-zero error code in INFO.
411*
412* Notes
413* =====
414*
415* A description vector is associated with each 2D block-cyclicly dis-
416* tributed matrix. This vector stores the information required to
417* establish the mapping between a matrix entry and its corresponding
418* process and memory location.
419*
420* In the following comments, the character _ should be read as
421* "of the distributed matrix". Let A be a generic term for any 2D
422* block cyclicly distributed matrix. Its description vector is DESCA:
423*
424* NOTATION STORED IN EXPLANATION
425* ---------------- --------------- ------------------------------------
426* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
427* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
428* the NPROW x NPCOL BLACS process grid
429* A is distributed over. The context
430* itself is global, but the handle
431* (the integer value) may vary.
432* M_A (global) DESCA( M_ ) The number of rows in the distribu-
433* ted matrix A, M_A >= 0.
434* N_A (global) DESCA( N_ ) The number of columns in the distri-
435* buted matrix A, N_A >= 0.
436* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
437* block of the matrix A, IMB_A > 0.
438* INB_A (global) DESCA( INB_ ) The number of columns of the upper
439* left block of the matrix A,
440* INB_A > 0.
441* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
442* bute the last M_A-IMB_A rows of A,
443* MB_A > 0.
444* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
445* bute the last N_A-INB_A columns of
446* A, NB_A > 0.
447* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
448* row of the matrix A is distributed,
449* NPROW > RSRC_A >= 0.
450* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
451* first column of A is distributed.
452* NPCOL > CSRC_A >= 0.
453* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
454* array storing the local blocks of
455* the distributed matrix A,
456* IF( Lc( 1, N_A ) > 0 )
457* LLD_A >= MAX( 1, Lr( 1, M_A ) )
458* ELSE
459* LLD_A >= 1.
460*
461* Let K be the number of rows of a matrix A starting at the global in-
462* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
463* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
464* receive if these K rows were distributed over NPROW processes. If K
465* is the number of columns of a matrix A starting at the global index
466* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
467* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
468* these K columns were distributed over NPCOL processes.
469*
470* The values of Lr() and Lc() may be determined via a call to the func-
471* tion PB_NUMROC:
472* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
473* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
474*
475* Arguments
476* =========
477*
478* ICTXT (local input) INTEGER
479* On entry, ICTXT specifies the BLACS context handle, indica-
480* ting the global context of the operation. The context itself
481* is global, but the value of ICTXT is local.
482*
483* NOUT (global input) INTEGER
484* On entry, NOUT specifies the unit number for the output file.
485* When NOUT is 6, output to screen, when NOUT is 0, output to
486* stderr. NOUT is only defined for process 0.
487*
488* MATRIX (global input) CHARACTER*1
489* On entry, MATRIX specifies the one character matrix identi-
490* fier.
491*
492* DESCX (global output) INTEGER array
493* On entry, DESCX is an array of dimension DLEN_. DESCX is the
494* array descriptor to be set.
495*
496* DTYPEX (global input) INTEGER
497* On entry, DTYPEX specifies the descriptor type. In this ver-
498* sion, DTYPEX must be BLOCK_CYCLIC_INB_2D.
499*
500* MX (global input) INTEGER
501* On entry, MX specifies the number of rows in the matrix. MX
502* must be at least zero.
503*
504* NX (global input) INTEGER
505* On entry, NX specifies the number of columns in the matrix.
506* NX must be at least zero.
507*
508* IMBX (global input) INTEGER
509* On entry, IMBX specifies the row blocking factor used to dis-
510* tribute the first IMBX rows of the matrix. IMBX must be at
511* least one.
512*
513* INBX (global input) INTEGER
514* On entry, INBX specifies the column blocking factor used to
515* distribute the first INBX columns of the matrix. INBX must
516* be at least one.
517*
518* MBX (global input) INTEGER
519* On entry, MBX specifies the row blocking factor used to dis-
520* tribute the rows of the matrix. MBX must be at least one.
521*
522* NBX (global input) INTEGER
523* On entry, NBX specifies the column blocking factor used to
524* distribute the columns of the matrix. NBX must be at least
525* one.
526*
527* RSRCX (global input) INTEGER
528* On entry, RSRCX specifies the process row in which the first
529* row of the matrix resides. When RSRCX is -1, the matrix is
530* row replicated, otherwise RSCRX must be at least zero and
531* strictly less than NPROW.
532*
533* CSRCX (global input) INTEGER
534* On entry, CSRCX specifies the process column in which the
535* first column of the matrix resides. When CSRCX is -1, the
536* matrix is column replicated, otherwise CSCRX must be at least
537* zero and strictly less than NPCOL.
538*
539* INCX (global input) INTEGER
540* On entry, INCX specifies the global vector increment. INCX
541* must be one or MX.
542*
543* MPX (local output) INTEGER
544* On exit, MPX is Lr( 1, MX ).
545*
546* NQX (local output) INTEGER
547* On exit, NQX is Lc( 1, NX ).
548*
549* IPREX (local output) INTEGER
550* On exit, IPREX specifies the size of the guard zone to put
551* before the start of the local padded array.
552*
553* IMIDX (local output) INTEGER
554* On exit, IMIDX specifies the ldx-gap of the guard zone to
555* put after each column of the local padded array.
556*
557* IPOSTX (local output) INTEGER
558* On exit, IPOSTX specifies the size of the guard zone to put
559* after the local padded array.
560*
561* IGAP (global input) INTEGER
562* On entry, IGAP specifies the size of the ldx-gap.
563*
564* GAPMUL (global input) INTEGER
565* On entry, GAPMUL is a constant factor controlling the size
566* of the pre- and post guardzone.
567*
568* INFO (global output) INTEGER
569* On exit, when INFO is zero, no error has been detected,
570* otherwise an error has been detected.
571*
572* -- Written on April 1, 1998 by
573* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
574*
575* =====================================================================
576*
577* .. Parameters ..
578 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
579 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
580 $ RSRC_
581 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
582 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
583 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
584 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
585* ..
586* .. Local Scalars ..
587 INTEGER LLDX, MYCOL, MYROW, NPCOL, NPROW
588* ..
589* .. External Subroutines ..
590 EXTERNAL blacs_gridinfo, igsum2d, pb_descinit2
591* ..
592* .. External Functions ..
593 INTEGER PB_NUMROC
594 EXTERNAL pb_numroc
595* ..
596* .. Intrinsic Functions ..
597 INTRINSIC max
598* ..
599* .. Executable Statements ..
600*
601 info = 0
602 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
603*
604* Verify descriptor type DTYPE_
605*
606 IF( dtx.NE.block_cyclic_2d_inb ) THEN
607 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
608 $ WRITE( nout, fmt = 9999 ) matrix, 'DTYPE', matrix, dtx,
609 $ block_cyclic_2d_inb
610 info = 1
611 END IF
612*
613* Verify global matrix dimensions (M_,N_) are correct
614*
615 IF( mx.LT.0 ) THEN
616 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
617 $ WRITE( nout, fmt = 9998 ) matrix, 'M', matrix, mx
618 info = 1
619 ELSE IF( nx.LT.0 ) THEN
620 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
621 $ WRITE( nout, fmt = 9997 ) matrix, 'N', matrix, nx
622 info = 1
623 END IF
624*
625* Verify if blocking factors (IMB_, INB_) are correct
626*
627 IF( imbx.LT.1 ) THEN
628 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
629 $ WRITE( nout, fmt = 9996 ) matrix, 'IMB', matrix, imbx
630 info = 1
631 ELSE IF( inbx.LT.1 ) THEN
632 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
633 $ WRITE( nout, fmt = 9995 ) matrix, 'INB', matrix, inbx
634 info = 1
635 END IF
636*
637* Verify if blocking factors (MB_, NB_) are correct
638*
639 IF( mbx.LT.1 ) THEN
640 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
641 $ WRITE( nout, fmt = 9994 ) matrix, 'MB', matrix, mbx
642 info = 1
643 ELSE IF( nbx.LT.1 ) THEN
644 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
645 $ WRITE( nout, fmt = 9993 ) matrix, 'NB', matrix, nbx
646 info = 1
647 END IF
648*
649* Verify if origin process coordinates (RSRC_, CSRC_) are valid
650*
651 IF( rsrcx.LT.-1 .OR. rsrcx.GE.nprow ) THEN
652 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
653 WRITE( nout, fmt = 9992 ) matrix
654 WRITE( nout, fmt = 9990 ) 'RSRC', matrix, rsrcx, nprow
655 END IF
656 info = 1
657 ELSE IF( csrcx.LT.-1 .OR. csrcx.GE.npcol ) THEN
658 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
659 WRITE( nout, fmt = 9991 ) matrix
660 WRITE( nout, fmt = 9990 ) 'CSRC', matrix, csrcx, npcol
661 END IF
662 info = 1
663 END IF
664*
665* Check input increment value
666*
667 IF( incx.NE.1 .AND. incx.NE.mx ) THEN
668 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
669 WRITE( nout, fmt = 9989 ) matrix
670 WRITE( nout, fmt = 9988 ) 'INC', matrix, incx, matrix, mx
671 END IF
672 info = 1
673 END IF
674*
675* Check all processes for an error
676*
677 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
678*
679 IF( info.NE.0 ) THEN
680*
681 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
682 WRITE( nout, fmt = 9987 ) matrix
683 WRITE( nout, fmt = * )
684 END IF
685*
686 ELSE
687*
688* Compute local testing leading dimension
689*
690 mpx = pb_numroc( mx, 1, imbx, mbx, myrow, rsrcx, nprow )
691 nqx = pb_numroc( nx, 1, inbx, nbx, mycol, csrcx, npcol )
692 iprex = max( gapmul*nbx, mpx )
693 imidx = igap
694 ipostx = max( gapmul*nbx, nqx )
695 lldx = max( 1, mpx ) + imidx
696*
697 CALL pb_descinit2( descx, mx, nx, imbx, inbx, mbx, nbx, rsrcx,
698 $ csrcx, ictxt, lldx, info )
699*
700* Check all processes for an error
701*
702 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
703*
704 IF( info.NE.0 ) THEN
705 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
706 WRITE( nout, fmt = 9987 ) matrix
707 WRITE( nout, fmt = * )
708 END IF
709 END IF
710*
711 END IF
712*
713 9999 FORMAT( 2x, '>> Invalid matrix ', a1, ' descriptor type ', a5, a1,
714 $ ': ', i6, ' should be ', i3, '.' )
715 9998 FORMAT( 2x, '>> Invalid matrix ', a1, ' row dimension ', a1, a1,
716 $ ': ', i6, ' should be at least 1.' )
717 9997 FORMAT( 2x, '>> Invalid matrix ', a1, ' column dimension ', A1,
718 $ A1, ': ', I6, ' should be at least 1.' )
719 9996 FORMAT( 2X, '>> invalid matrix ', A1, ' first row block size ',
720 $ A3, A1, ': ', I6, ' should be at least 1.' )
721 9995 FORMAT( 2X, '>> invalid matrix ', A1, ' first column block size ',
722 $ A3, A1,': ', I6, ' should be at least 1.' )
723 9994 FORMAT( 2X, '>> invalid matrix ', A1, ' row block size ', A2, A1,
724 $ ': ', I6, ' should be at least 1.' )
725 9993 FORMAT( 2X, '>> invalid matrix ', A1, ' column block size ', A2,
726 $ A1,': ', I6, ' should be at least 1.' )
727 9992 FORMAT( 2X, '>> invalid matrix ', A1, ' row process source:' )
728 9991 FORMAT( 2x, '>> Invalid matrix ', a1, ' column process source:' )
729 9990 FORMAT( 2x, '>> ', a4, a1, '= ', i6, ' should be >= -1 and < ',
730 $ i6, '.' )
731 9989 FORMAT( 2x, '>> Invalid vector ', a1, ' increment:' )
732 9988 FORMAT( 2X, '>> ', A3, A1, '= ', I6, ' should be 1 or m', A1,
733 $ ' = ', I6, '.' )
734 9987 FORMAT( 2X, '>> invalid matrix ', A1, ' descriptor: going on to ',
735 $ 'next test case.' )
736*
737 RETURN
738*
739* End of PVDESCCHK
740*

◆ pvdimchk()

subroutine pvdimchk ( integer ictxt,
integer nout,
integer n,
character*1 matrix,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
integer info )

Definition at line 1 of file pblastim.f.

3*
4* -- PBLAS test routine (version 2.0) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* April 1, 1998
8*
9* .. Scalar Arguments ..
10 CHARACTER*1 MATRIX
11 INTEGER ICTXT, INCX, INFO, IX, JX, N, NOUT
12* ..
13* .. Array Arguments ..
14 INTEGER DESCX( * )
15* ..
16*
17* Purpose
18* =======
19*
20* PVDIMCHK checks the validity of the input test dimensions. In case of
21* an invalid parameter or discrepancy between the parameters, this rou-
22* tine displays error messages and returns an non-zero error code in
23* INFO.
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* ICTXT (local input) INTEGER
92* On entry, ICTXT specifies the BLACS context handle, indica-
93* ting the global context of the operation. The context itself
94* is global, but the value of ICTXT is local.
95*
96* NOUT (global input) INTEGER
97* On entry, NOUT specifies the unit number for the output file.
98* When NOUT is 6, output to screen, when NOUT is 0, output to
99* stderr. NOUT is only defined for process 0.
100*
101* MATRIX (global input) CHARACTER*1
102* On entry, MATRIX specifies the one character matrix identi-
103* fier.
104*
105* IX (global input) INTEGER
106* On entry, IX specifies X's global row index, which points to
107* the beginning of the submatrix sub( X ).
108*
109* JX (global input) INTEGER
110* On entry, JX specifies X's global column index, which points
111* to the beginning of the submatrix sub( X ).
112*
113* DESCX (global and local input) INTEGER array
114* On entry, DESCX is an integer array of dimension DLEN_. This
115* is the array descriptor for the matrix X.
116*
117* INCX (global input) INTEGER
118* On entry, INCX specifies the global increment for the
119* elements of X. Only two values of INCX are supported in
120* this version, namely 1 and M_X. INCX must not be zero.
121*
122* INFO (global output) INTEGER
123* On exit, when INFO is zero, no error has been detected,
124* otherwise an error has been detected.
125*
126* -- Written on April 1, 1998 by
127* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
128*
129* =====================================================================
130*
131* .. Parameters ..
132 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
133 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
134 $ RSRC_
135 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
136 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
137 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
138 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
139* ..
140* .. Local Scalars ..
141 INTEGER MYCOL, MYROW, NPCOL, NPROW
142* ..
143* .. External Subroutines ..
144 EXTERNAL blacs_gridinfo, igsum2d
145* ..
146* .. Executable Statements ..
147*
148 info = 0
149 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
150*
151 IF( n.LT.0 ) THEN
152 info = 1
153 ELSE IF( n.EQ.0 ) THEN
154 IF( descx( m_ ).LT.0 )
155 $ info = 1
156 IF( descx( n_ ).LT.0 )
157 $ info = 1
158 ELSE
159 IF( incx.EQ.descx( m_ ) .AND.
160 $ descx( n_ ).LT.( jx+n-1 ) ) THEN
161 info = 1
162 ELSE IF( incx.EQ.1 .AND. incx.NE.descx( m_ ) .AND.
163 $ descx( m_ ).LT.( ix+n-1 ) ) THEN
164 info = 1
165 ELSE
166 IF( ix.GT.descx( m_ ) ) THEN
167 info = 1
168 ELSE IF( jx.GT.descx( n_ ) ) THEN
169 info = 1
170 END IF
171 END IF
172 END IF
173*
174* Check all processes for an error
175*
176 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
177*
178 IF( info.NE.0 ) THEN
179 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
180 WRITE( nout, fmt = 9999 ) matrix
181 WRITE( nout, fmt = 9998 ) n, matrix, ix, matrix, jx, matrix,
182 $ incx
183 WRITE( nout, fmt = 9997 ) matrix, descx( m_ ), matrix,
184 $ descx( n_ )
185 WRITE( nout, fmt = * )
186 END IF
187 END IF
188*
189 9999 FORMAT( 'Incompatible arguments for matrix ', a1, ':' )
190 9998 FORMAT( 'N = ', i6, ', I', a1, ' = ', i6, ', J', a1, ' = ',
191 $ i6, ',INC', a1, ' = ', i6 )
192 9997 FORMAT( 'DESC', a1, '( M_ ) = ', i6, ', DESC', a1, '( N_ ) = ',
193 $ i6, '.' )
194*
195 RETURN
196*
197* End of PVDIMCHK
198*

◆ pxerbla()

subroutine pxerbla ( integer ictxt,
character*(*) srname,
integer info )

Definition at line 1537 of file pblastim.f.

1538*
1539* -- PBLAS test routine (version 2.0) --
1540* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1541* and University of California, Berkeley.
1542* April 1, 1998
1543*
1544* .. Scalar Arguments ..
1545 INTEGER ICTXT, INFO
1546* ..
1547* .. Array Arguments ..
1548 CHARACTER*(*) SRNAME
1549* ..
1550*
1551* Purpose
1552* =======
1553*
1554* PXERBLA is an error handler for the ScaLAPACK routines. It is called
1555* by a ScaLAPACK routine if an input parameter has an invalid value. A
1556* message is printed. Installers may consider modifying this routine in
1557* order to call system-specific exception-handling facilities.
1558*
1559* Arguments
1560* =========
1561*
1562* ICTXT (local input) INTEGER
1563* On entry, ICTXT specifies the BLACS context handle, indica-
1564* ting the global context of the operation. The context itself
1565* is global, but the value of ICTXT is local.
1566*
1567* SRNAME (global input) CHARACTER*(*)
1568* On entry, SRNAME specifies the name of the routine which cal-
1569* ling PXERBLA.
1570*
1571* INFO (global input) INTEGER
1572* On entry, INFO specifies the position of the invalid parame-
1573* ter in the parameter list of the calling routine.
1574*
1575* -- Written on April 1, 1998 by
1576* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1577*
1578* =====================================================================
1579*
1580* .. Local Scalars ..
1581 INTEGER MYCOL, MYROW, NPCOL, NPROW
1582* ..
1583* .. External Subroutines ..
1584 EXTERNAL blacs_gridinfo
1585* ..
1586* .. Executable Statements ..
1587*
1588 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1589*
1590 WRITE( *, fmt = 9999 ) myrow, mycol, srname, info
1591*
1592 9999 FORMAT( '{', i5, ',', i5, '}: On entry to ', a,
1593 $ ' parameter number ', i4, ' had an illegal value' )
1594*
1595 RETURN
1596*
1597* End of PXERBLA
1598*