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

◆ pdblas1tstchk()

subroutine pdblas1tstchk ( integer  ictxt,
integer  nout,
integer  nrout,
integer  n,
double precision  psclr,
double precision  pusclr,
integer  pisclr,
double precision, dimension( * )  x,
double precision, dimension( * )  px,
integer  ix,
integer  jx,
integer, dimension( * )  descx,
integer  incx,
double precision, dimension( * )  y,
double precision, dimension( * )  py,
integer  iy,
integer  jy,
integer, dimension( * )  descy,
integer  incy,
integer  info 
)

Definition at line 2208 of file pdblas1tst.f.

2211*
2212* -- PBLAS test routine (version 2.0) --
2213* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2214* and University of California, Berkeley.
2215* April 1, 1998
2216*
2217* .. Scalar Arguments ..
2218 INTEGER ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N,
2219 $ NOUT, NROUT, PISCLR
2220 DOUBLE PRECISION PSCLR, PUSCLR
2221* ..
2222* .. Array Arguments ..
2223 INTEGER DESCX( * ), DESCY( * )
2224 DOUBLE PRECISION PX( * ), PY( * ), X( * ), Y( * )
2225* ..
2226*
2227* Purpose
2228* =======
2229*
2230* PDBLAS1TSTCHK performs the computational tests of the Level 1 PBLAS.
2231*
2232* Notes
2233* =====
2234*
2235* A description vector is associated with each 2D block-cyclicly dis-
2236* tributed matrix. This vector stores the information required to
2237* establish the mapping between a matrix entry and its corresponding
2238* process and memory location.
2239*
2240* In the following comments, the character _ should be read as
2241* "of the distributed matrix". Let A be a generic term for any 2D
2242* block cyclicly distributed matrix. Its description vector is DESCA:
2243*
2244* NOTATION STORED IN EXPLANATION
2245* ---------------- --------------- ------------------------------------
2246* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2247* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2248* the NPROW x NPCOL BLACS process grid
2249* A is distributed over. The context
2250* itself is global, but the handle
2251* (the integer value) may vary.
2252* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2253* ted matrix A, M_A >= 0.
2254* N_A (global) DESCA( N_ ) The number of columns in the distri-
2255* buted matrix A, N_A >= 0.
2256* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2257* block of the matrix A, IMB_A > 0.
2258* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2259* left block of the matrix A,
2260* INB_A > 0.
2261* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2262* bute the last M_A-IMB_A rows of A,
2263* MB_A > 0.
2264* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2265* bute the last N_A-INB_A columns of
2266* A, NB_A > 0.
2267* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2268* row of the matrix A is distributed,
2269* NPROW > RSRC_A >= 0.
2270* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2271* first column of A is distributed.
2272* NPCOL > CSRC_A >= 0.
2273* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2274* array storing the local blocks of
2275* the distributed matrix A,
2276* IF( Lc( 1, N_A ) > 0 )
2277* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2278* ELSE
2279* LLD_A >= 1.
2280*
2281* Let K be the number of rows of a matrix A starting at the global in-
2282* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2283* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2284* receive if these K rows were distributed over NPROW processes. If K
2285* is the number of columns of a matrix A starting at the global index
2286* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2287* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2288* these K columns were distributed over NPCOL processes.
2289*
2290* The values of Lr() and Lc() may be determined via a call to the func-
2291* tion PB_NUMROC:
2292* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2293* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2294*
2295* Arguments
2296* =========
2297*
2298* ICTXT (local input) INTEGER
2299* On entry, ICTXT specifies the BLACS context handle, indica-
2300* ting the global context of the operation. The context itself
2301* is global, but the value of ICTXT is local.
2302*
2303* NOUT (global input) INTEGER
2304* On entry, NOUT specifies the unit number for the output file.
2305* When NOUT is 6, output to screen, when NOUT is 0, output to
2306* stderr. NOUT is only defined for process 0.
2307*
2308* NROUT (global input) INTEGER
2309* On entry, NROUT specifies which routine will be tested as
2310* follows:
2311* If NROUT = 1, PDSWAP will be tested;
2312* else if NROUT = 2, PDSCAL will be tested;
2313* else if NROUT = 3, PDCOPY will be tested;
2314* else if NROUT = 4, PDAXPY will be tested;
2315* else if NROUT = 5, PDDOT will be tested;
2316* else if NROUT = 6, PDNRM2 will be tested;
2317* else if NROUT = 7, PDASUM will be tested;
2318* else if NROUT = 8, PDAMAX will be tested.
2319*
2320* N (global input) INTEGER
2321* On entry, N specifies the length of the subvector operands.
2322*
2323* PSCLR (global input) DOUBLE PRECISION
2324* On entry, depending on the value of NROUT, PSCLR specifies
2325* the scalar ALPHA, or the output scalar returned by the PBLAS,
2326* i.e., the dot product, the 2-norm, the absolute sum or the
2327* value of AMAX.
2328*
2329* PUSCLR (global input) DOUBLE PRECISION
2330* On entry, PUSCLR specifies the real part of the scalar ALPHA
2331* used by the real scaling, the 2-norm, or the absolute sum
2332* routines. PUSCLR is not used in the real versions of this
2333* routine.
2334*
2335* PISCLR (global input) DOUBLE PRECISION
2336* On entry, PISCLR specifies the value of the global index re-
2337* turned by PDAMAX, otherwise PISCLR is not used.
2338*
2339* X (local input/local output) DOUBLE PRECISION array
2340* On entry, X is an array of dimension (DESCX( M_ ),*). This
2341* array contains a local copy of the initial entire matrix PX.
2342*
2343* PX (local input) DOUBLE PRECISION array
2344* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2345* array contains the local entries of the matrix PX.
2346*
2347* IX (global input) INTEGER
2348* On entry, IX specifies X's global row index, which points to
2349* the beginning of the submatrix sub( X ).
2350*
2351* JX (global input) INTEGER
2352* On entry, JX specifies X's global column index, which points
2353* to the beginning of the submatrix sub( X ).
2354*
2355* DESCX (global and local input) INTEGER array
2356* On entry, DESCX is an integer array of dimension DLEN_. This
2357* is the array descriptor for the matrix X.
2358*
2359* INCX (global input) INTEGER
2360* On entry, INCX specifies the global increment for the
2361* elements of X. Only two values of INCX are supported in
2362* this version, namely 1 and M_X. INCX must not be zero.
2363*
2364* Y (local input/local output) DOUBLE PRECISION array
2365* On entry, Y is an array of dimension (DESCY( M_ ),*). This
2366* array contains a local copy of the initial entire matrix PY.
2367*
2368* PY (local input) DOUBLE PRECISION array
2369* On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
2370* array contains the local entries of the matrix PY.
2371*
2372* IY (global input) INTEGER
2373* On entry, IY specifies Y's global row index, which points to
2374* the beginning of the submatrix sub( Y ).
2375*
2376* JY (global input) INTEGER
2377* On entry, JY specifies Y's global column index, which points
2378* to the beginning of the submatrix sub( Y ).
2379*
2380* DESCY (global and local input) INTEGER array
2381* On entry, DESCY is an integer array of dimension DLEN_. This
2382* is the array descriptor for the matrix Y.
2383*
2384* INCY (global input) INTEGER
2385* On entry, INCY specifies the global increment for the
2386* elements of Y. Only two values of INCY are supported in
2387* this version, namely 1 and M_Y. INCY must not be zero.
2388*
2389* INFO (global output) INTEGER
2390* On exit, if INFO = 0, no error has been found, otherwise
2391* if( MOD( INFO, 2 ) = 1 ) then an error on X has been found,
2392* if( MOD( INFO/2, 2 ) = 1 ) then an error on Y has been found.
2393*
2394* -- Written on April 1, 1998 by
2395* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2396*
2397* =====================================================================
2398*
2399* .. Parameters ..
2400 DOUBLE PRECISION ZERO
2401 parameter( zero = 0.0d+0 )
2402 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2403 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2404 $ RSRC_
2405 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2406 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2407 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2408 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2409* ..
2410* .. Local Scalars ..
2411 LOGICAL COLREP, INXSCOPE, INYSCOPE, ROWREP
2412 INTEGER I, IB, ICURCOL, ICURROW, IDUMM, IIX, IIY, IN,
2413 $ IOFFX, IOFFY, ISCLR, IXCOL, IXROW, IYCOL,
2414 $ IYROW, J, JB, JJX, JJY, JN, KK, LDX, LDY,
2415 $ MYCOL, MYROW, NPCOL, NPROW
2416 DOUBLE PRECISION ERR, ERRMAX, PREC, SCLR, USCLR
2417* ..
2418* .. Local Arrays ..
2419 INTEGER IERR( 6 )
2420 CHARACTER*5 ARGIN1, ARGIN2, ARGOUT1, ARGOUT2
2421* ..
2422* .. External Subroutines ..
2423 EXTERNAL blacs_gridinfo, dcopy, dswap, igamx2d,
2424 $ pb_infog2l, pdchkvin, pderrasum, pderraxpy,
2425 $ pderrdot, pderrnrm2, pderrscal
2426* ..
2427* .. External Functions ..
2428 LOGICAL PISINSCOPE
2429 INTEGER IDAMAX
2430 DOUBLE PRECISION PDLAMCH
2431 EXTERNAL idamax, pdlamch, pisinscope
2432* ..
2433* .. Intrinsic Functions ..
2434 INTRINSIC min
2435* ..
2436* .. Executable Statements ..
2437*
2438 info = 0
2439*
2440* Quick return if possible
2441*
2442 IF( n.LE.0 )
2443 $ RETURN
2444*
2445 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2446*
2447 argin1 = ' '
2448 argin2 = ' '
2449 argout1 = ' '
2450 argout2 = ' '
2451 DO 10 i = 1, 6
2452 ierr( i ) = 0
2453 10 CONTINUE
2454*
2455 prec = pdlamch( ictxt, 'precision' )
2456*
2457 IF( nrout.EQ.1 ) THEN
2458*
2459* Test PDSWAP
2460*
2461 ioffx = ix + ( jx - 1 ) * descx( m_ )
2462 ioffy = iy + ( jy - 1 ) * descy( m_ )
2463 CALL dswap( n, x( ioffx ), incx, y( ioffy ), incy )
2464 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2465 $ ierr( 1 ) )
2466 CALL pdchkvin( errmax, n, y, py, iy, jy, descy, incy,
2467 $ ierr( 2 ) )
2468*
2469 ELSE IF( nrout.EQ.2 ) THEN
2470*
2471* Test PDSCAL
2472*
2473 ldx = descx( lld_ )
2474 ioffx = ix + ( jx - 1 ) * descx( m_ )
2475 CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2476 $ iix, jjx, ixrow, ixcol )
2477 icurrow = ixrow
2478 icurcol = ixcol
2479 rowrep = ( ixrow.EQ.-1 )
2480 colrep = ( ixcol.EQ.-1 )
2481*
2482 IF( incx.EQ.descx( m_ ) ) THEN
2483*
2484* sub( X ) is a row vector
2485*
2486 jb = descx( inb_ ) - jx + 1
2487 IF( jb.LE.0 )
2488 $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2489 jb = min( jb, n )
2490 jn = jx + jb - 1
2491*
2492 DO 20 j = jx, jn
2493*
2494 CALL pderrscal( err, psclr, x( ioffx ), prec )
2495*
2496 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2497 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2498 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2499 $ err )
2500 $ ierr( 1 ) = 1
2501 jjx = jjx + 1
2502 END IF
2503*
2504 ioffx = ioffx + incx
2505*
2506 20 CONTINUE
2507*
2508 icurcol = mod( icurcol+1, npcol )
2509*
2510 DO 40 j = jn+1, jx+n-1, descx( nb_ )
2511 jb = min( jx+n-j, descx( nb_ ) )
2512*
2513 DO 30 kk = 0, jb-1
2514*
2515 CALL pderrscal( err, psclr, x( ioffx ), prec )
2516*
2517 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2518 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2519 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2520 $ err )
2521 $ ierr( 1 ) = 1
2522 jjx = jjx + 1
2523 END IF
2524*
2525 ioffx = ioffx + incx
2526*
2527 30 CONTINUE
2528*
2529 icurcol = mod( icurcol+1, npcol )
2530*
2531 40 CONTINUE
2532*
2533 ELSE
2534*
2535* sub( X ) is a column vector
2536*
2537 ib = descx( imb_ ) - ix + 1
2538 IF( ib.LE.0 )
2539 $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2540 ib = min( ib, n )
2541 in = ix + ib - 1
2542*
2543 DO 50 i = ix, in
2544*
2545 CALL pderrscal( err, psclr, x( ioffx ), prec )
2546*
2547 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2548 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2549 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2550 $ err )
2551 $ ierr( 1 ) = 1
2552 iix = iix + 1
2553 END IF
2554*
2555 ioffx = ioffx + incx
2556*
2557 50 CONTINUE
2558*
2559 icurrow = mod( icurrow+1, nprow )
2560*
2561 DO 70 i = in+1, ix+n-1, descx( mb_ )
2562 ib = min( ix+n-i, descx( mb_ ) )
2563*
2564 DO 60 kk = 0, ib-1
2565*
2566 CALL pderrscal( err, psclr, x( ioffx ), prec )
2567*
2568 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2569 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2570 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2571 $ err )
2572 $ ierr( 1 ) = 1
2573 iix = iix + 1
2574 END IF
2575*
2576 ioffx = ioffx + incx
2577 60 CONTINUE
2578*
2579 icurrow = mod( icurrow+1, nprow )
2580*
2581 70 CONTINUE
2582*
2583 END IF
2584*
2585 ELSE IF( nrout.EQ.3 ) THEN
2586*
2587* Test PDCOPY
2588*
2589 ioffx = ix + ( jx - 1 ) * descx( m_ )
2590 ioffy = iy + ( jy - 1 ) * descy( m_ )
2591 CALL dcopy( n, x( ioffx ), incx, y( ioffy ), incy )
2592 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2593 $ ierr( 1 ) )
2594 CALL pdchkvin( errmax, n, y, py, iy, jy, descy, incy,
2595 $ ierr( 2 ) )
2596*
2597 ELSE IF( nrout.EQ.4 ) THEN
2598*
2599* Test PDAXPY
2600*
2601 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2602 $ ierr( 1 ) )
2603 ldy = descy( lld_ )
2604 ioffx = ix + ( jx - 1 ) * descx( m_ )
2605 ioffy = iy + ( jy - 1 ) * descy( m_ )
2606 CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol,
2607 $ iiy, jjy, iyrow, iycol )
2608 icurrow = iyrow
2609 icurcol = iycol
2610 rowrep = ( iyrow.EQ.-1 )
2611 colrep = ( iycol.EQ.-1 )
2612*
2613 IF( incy.EQ.descy( m_ ) ) THEN
2614*
2615* sub( Y ) is a row vector
2616*
2617 jb = descy( inb_ ) - jy + 1
2618 IF( jb.LE.0 )
2619 $ jb = ( (-jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
2620 jb = min( jb, n )
2621 jn = jy + jb - 1
2622*
2623 DO 140 j = jy, jn
2624*
2625 CALL pderraxpy( err, psclr, x( ioffx ), y( ioffy ),
2626 $ prec )
2627*
2628 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2629 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2630 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2631 $ err ) THEN
2632 ierr( 2 ) = 1
2633 END IF
2634 jjy = jjy + 1
2635 END IF
2636*
2637 ioffx = ioffx + incx
2638 ioffy = ioffy + incy
2639*
2640 140 CONTINUE
2641*
2642 icurcol = mod( icurcol+1, npcol )
2643*
2644 DO 160 j = jn+1, jy+n-1, descy( nb_ )
2645 jb = min( jy+n-j, descy( nb_ ) )
2646*
2647 DO 150 kk = 0, jb-1
2648*
2649 CALL pderraxpy( err, psclr, x( ioffx ), y( ioffy ),
2650 $ prec )
2651*
2652 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2653 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2654 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2655 $ err ) THEN
2656 ierr( 2 ) = 1
2657 END IF
2658 jjy = jjy + 1
2659 END IF
2660*
2661 ioffx = ioffx + incx
2662 ioffy = ioffy + incy
2663*
2664 150 CONTINUE
2665*
2666 icurcol = mod( icurcol+1, npcol )
2667*
2668 160 CONTINUE
2669*
2670 ELSE
2671*
2672* sub( Y ) is a column vector
2673*
2674 ib = descy( imb_ ) - iy + 1
2675 IF( ib.LE.0 )
2676 $ ib = ( (-ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
2677 ib = min( ib, n )
2678 in = iy + ib - 1
2679*
2680 DO 170 i = iy, in
2681*
2682 CALL pderraxpy( err, psclr, x( ioffx ), y( ioffy ),
2683 $ prec )
2684*
2685 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2686 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2687 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2688 $ err ) THEN
2689 ierr( 2 ) = 1
2690 END IF
2691 iiy = iiy + 1
2692 END IF
2693*
2694 ioffx = ioffx + incx
2695 ioffy = ioffy + incy
2696*
2697 170 CONTINUE
2698*
2699 icurrow = mod( icurrow+1, nprow )
2700*
2701 DO 190 i = in+1, iy+n-1, descy( mb_ )
2702 ib = min( iy+n-i, descy( mb_ ) )
2703*
2704 DO 180 kk = 0, ib-1
2705*
2706 CALL pderraxpy( err, psclr, x( ioffx ), y( ioffy ),
2707 $ prec )
2708*
2709 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2710 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2711 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2712 $ err ) THEN
2713 ierr( 2 ) = 1
2714 END IF
2715 iiy = iiy + 1
2716 END IF
2717*
2718 ioffx = ioffx + incx
2719 ioffy = ioffy + incy
2720*
2721 180 CONTINUE
2722*
2723 icurrow = mod( icurrow+1, nprow )
2724*
2725 190 CONTINUE
2726*
2727 END IF
2728*
2729 ELSE IF( nrout.EQ.5 ) THEN
2730*
2731* Test PDDOT
2732*
2733 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2734 $ ierr( 1 ) )
2735 CALL pdchkvin( errmax, n, y, py, iy, jy, descy, incy,
2736 $ ierr( 2 ) )
2737 ioffx = ix + ( jx - 1 ) * descx( m_ )
2738 ioffy = iy + ( jy - 1 ) * descy( m_ )
2739 CALL pderrdot( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2740 $ incy, prec )
2741 inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2742 inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2743 IF( inxscope.OR.inyscope ) THEN
2744 IF( abs( psclr - sclr ).GT.err ) THEN
2745 ierr( 3 ) = 1
2746 WRITE( argin1, fmt = '(A)' ) 'DOT'
2747 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2748 WRITE( nout, fmt = 9998 ) argin1
2749 WRITE( nout, fmt = 9996 ) sclr, psclr
2750 END IF
2751 END IF
2752 ELSE
2753 sclr = zero
2754 IF( psclr.NE.sclr ) THEN
2755 ierr( 4 ) = 1
2756 WRITE( argout1, fmt = '(A)' ) 'DOT'
2757 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2758 WRITE( nout, fmt = 9997 ) argout1
2759 WRITE( nout, fmt = 9996 ) sclr, psclr
2760 END IF
2761 END IF
2762 END IF
2763*
2764 ELSE IF( nrout.EQ.6 ) THEN
2765*
2766* Test PDNRM2
2767*
2768 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2769 $ ierr( 1 ) )
2770 ioffx = ix + ( jx - 1 ) * descx( m_ )
2771 CALL pderrnrm2( err, n, usclr, x( ioffx ), incx, prec )
2772 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2773 IF( abs( pusclr - usclr ).GT.err ) THEN
2774 ierr( 3 ) = 1
2775 WRITE( argin1, fmt = '(A)' ) 'NRM2'
2776 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2777 WRITE( nout, fmt = 9998 ) argin1
2778 WRITE( nout, fmt = 9996 ) usclr, pusclr
2779 END IF
2780 END IF
2781 ELSE
2782 usclr = zero
2783 IF( pusclr.NE.usclr ) THEN
2784 ierr( 4 ) = 1
2785 WRITE( argout1, fmt = '(A)' ) 'NRM2'
2786 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2787 WRITE( nout, fmt = 9997 ) argout1
2788 WRITE( nout, fmt = 9996 ) usclr, pusclr
2789 END IF
2790 END IF
2791 END IF
2792*
2793 ELSE IF( nrout.EQ.7 ) THEN
2794*
2795* Test PDASUM
2796*
2797 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2798 $ ierr( 1 ) )
2799 ioffx = ix + ( jx - 1 ) * descx( m_ )
2800 CALL pderrasum( err, n, usclr, x( ioffx ), incx, prec )
2801 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2802 IF( abs( pusclr - usclr ) .GT. err ) THEN
2803 ierr( 3 ) = 1
2804 WRITE( argin1, fmt = '(A)' ) 'ASUM'
2805 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2806 WRITE( nout, fmt = 9998 ) argin1
2807 WRITE( nout, fmt = 9996 ) usclr, pusclr
2808 END IF
2809 END IF
2810 ELSE
2811 usclr = zero
2812 IF( pusclr.NE.usclr ) THEN
2813 ierr( 4 ) = 1
2814 WRITE( argout1, fmt = '(A)' ) 'ASUM'
2815 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2816 WRITE( nout, fmt = 9997 ) argout1
2817 WRITE( nout, fmt = 9996 ) usclr, pusclr
2818 END IF
2819 END IF
2820 END IF
2821*
2822 ELSE IF( nrout.EQ.8 ) THEN
2823*
2824* Test PDAMAX
2825*
2826 CALL pdchkvin( errmax, n, x, px, ix, jx, descx, incx,
2827 $ ierr( 1 ) )
2828 ioffx = ix + ( jx - 1 ) * descx( m_ )
2829 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2830 isclr = idamax( n, x( ioffx ), incx )
2831 IF( n.LT.1 ) THEN
2832 sclr = zero
2833 ELSE IF( ( incx.EQ.1 ).AND.( descx( m_ ).EQ.1 ).AND.
2834 $ ( n.EQ.1 ) ) THEN
2835 isclr = jx
2836 sclr = x( ioffx )
2837 ELSE IF( incx.EQ.descx( m_ ) ) THEN
2838 isclr = jx + isclr - 1
2839 sclr = x( ix + ( isclr - 1 ) * descx( m_ ) )
2840 ELSE
2841 isclr = ix + isclr - 1
2842 sclr = x( isclr + ( jx - 1 ) * descx( m_ ) )
2843 END IF
2844*
2845 IF( psclr.NE.sclr ) THEN
2846 ierr( 3 ) = 1
2847 WRITE( argin1, fmt = '(A)' ) 'AMAX'
2848 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2849 WRITE( nout, fmt = 9998 ) argin1
2850 WRITE( nout, fmt = 9996 ) sclr, psclr
2851 END IF
2852 END IF
2853*
2854 IF( pisclr.NE.isclr ) THEN
2855 ierr( 5 ) = 1
2856 WRITE( argin2, fmt = '(A)' ) 'INDX'
2857 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2858 WRITE( nout, fmt = 9998 ) argin2
2859 WRITE( nout, fmt = 9995 ) isclr, pisclr
2860 END IF
2861 END IF
2862 ELSE
2863 isclr = 0
2864 sclr = zero
2865 IF( psclr.NE.sclr ) THEN
2866 ierr( 4 ) = 1
2867 WRITE( argout1, fmt = '(A)' ) 'AMAX'
2868 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2869 WRITE( nout, fmt = 9997 ) argout1
2870 WRITE( nout, fmt = 9996 ) sclr, psclr
2871 END IF
2872 END IF
2873 IF( pisclr.NE.isclr ) THEN
2874 ierr( 6 ) = 1
2875 WRITE( argout2, fmt = '(A)' ) 'INDX'
2876 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2877 WRITE( nout, fmt = 9997 ) argout2
2878 WRITE( nout, fmt = 9995 ) isclr, pisclr
2879 END IF
2880 END IF
2881 END IF
2882*
2883 END IF
2884*
2885* Find IERR across all processes
2886*
2887 CALL igamx2d( ictxt, 'All', ' ', 6, 1, ierr, 6, idumm, idumm, -1,
2888 $ -1, 0 )
2889*
2890* Encode the errors found in INFO
2891*
2892 IF( ierr( 1 ).NE.0 ) THEN
2893 info = info + 1
2894 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2895 $ WRITE( nout, fmt = 9999 ) 'X'
2896 END IF
2897*
2898 IF( ierr( 2 ).NE.0 ) THEN
2899 info = info + 2
2900 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2901 $ WRITE( nout, fmt = 9999 ) 'Y'
2902 END IF
2903*
2904 IF( ierr( 3 ).NE.0 )
2905 $ info = info + 4
2906*
2907 IF( ierr( 4 ).NE.0 )
2908 $ info = info + 8
2909*
2910 IF( ierr( 5 ).NE.0 )
2911 $ info = info + 16
2912*
2913 IF( ierr( 6 ).NE.0 )
2914 $ info = info + 32
2915*
2916 9999 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
2917 $ ' is incorrect.' )
2918 9998 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
2919 $ ' in scope is incorrect.' )
2920 9997 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
2921 $ ' out of scope is incorrect.' )
2922 9996 FORMAT( 2x, ' ***** Expected value is: ', d30.18, /2x,
2923 $ ' Obtained value is: ', d30.18 )
2924 9995 FORMAT( 2x, ' ***** Expected value is: ', i6, /2x,
2925 $ ' Obtained value is: ', i6 )
2926*
2927 RETURN
2928*
2929* End of PDBLAS1TSTCHK
2930*
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pisinscope
logical function pisinscope(ictxt, n, ix, jx, descx, incx)
Definition pcblas1tst.f:2078
min
#define min(A, B)
Definition pcgemr.c:181
pderrnrm2
subroutine pderrnrm2(errbnd, n, usclr, x, incx, prec)
Definition pdblas1tst.f:3047
pderrdot
subroutine pderrdot(errbnd, n, sclr, x, incx, y, incy, prec)
Definition pdblas1tst.f:2933
pderraxpy
subroutine pderraxpy(errbnd, psclr, x, y, prec)
Definition pdblas1tst.f:3313
pderrasum
subroutine pderrasum(errbnd, n, usclr, x, incx, prec)
Definition pdblas1tst.f:3164
pderrscal
subroutine pderrscal(errbnd, psclr, x, prec)
Definition pdblas1tst.f:3246
pdchkvin
subroutine pdchkvin(errmax, n, x, px, ix, jx, descx, incx, info)
Definition pdblastst.f:2576
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
Here is the call graph for this function:
Here is the caller graph for this function: