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

◆ pzblas1tstchk()

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

Definition at line 2252 of file pzblas1tst.f.

2255*
2256* -- PBLAS test routine (version 2.0) --
2257* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2258* and University of California, Berkeley.
2259* April 1, 1998
2260*
2261* .. Scalar Arguments ..
2262 INTEGER ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N,
2263 $ NOUT, NROUT, PISCLR
2264 DOUBLE PRECISION PUSCLR
2265 COMPLEX*16 PSCLR
2266* ..
2267* .. Array Arguments ..
2268 INTEGER DESCX( * ), DESCY( * )
2269 COMPLEX*16 PX( * ), PY( * ), X( * ), Y( * )
2270* ..
2271*
2272* Purpose
2273* =======
2274*
2275* PZBLAS1TSTCHK performs the computational tests of the Level 1 PBLAS.
2276*
2277* Notes
2278* =====
2279*
2280* A description vector is associated with each 2D block-cyclicly dis-
2281* tributed matrix. This vector stores the information required to
2282* establish the mapping between a matrix entry and its corresponding
2283* process and memory location.
2284*
2285* In the following comments, the character _ should be read as
2286* "of the distributed matrix". Let A be a generic term for any 2D
2287* block cyclicly distributed matrix. Its description vector is DESCA:
2288*
2289* NOTATION STORED IN EXPLANATION
2290* ---------------- --------------- ------------------------------------
2291* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2292* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2293* the NPROW x NPCOL BLACS process grid
2294* A is distributed over. The context
2295* itself is global, but the handle
2296* (the integer value) may vary.
2297* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2298* ted matrix A, M_A >= 0.
2299* N_A (global) DESCA( N_ ) The number of columns in the distri-
2300* buted matrix A, N_A >= 0.
2301* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2302* block of the matrix A, IMB_A > 0.
2303* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2304* left block of the matrix A,
2305* INB_A > 0.
2306* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2307* bute the last M_A-IMB_A rows of A,
2308* MB_A > 0.
2309* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2310* bute the last N_A-INB_A columns of
2311* A, NB_A > 0.
2312* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2313* row of the matrix A is distributed,
2314* NPROW > RSRC_A >= 0.
2315* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2316* first column of A is distributed.
2317* NPCOL > CSRC_A >= 0.
2318* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2319* array storing the local blocks of
2320* the distributed matrix A,
2321* IF( Lc( 1, N_A ) > 0 )
2322* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2323* ELSE
2324* LLD_A >= 1.
2325*
2326* Let K be the number of rows of a matrix A starting at the global in-
2327* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2328* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2329* receive if these K rows were distributed over NPROW processes. If K
2330* is the number of columns of a matrix A starting at the global index
2331* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2332* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2333* these K columns were distributed over NPCOL processes.
2334*
2335* The values of Lr() and Lc() may be determined via a call to the func-
2336* tion PB_NUMROC:
2337* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2338* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2339*
2340* Arguments
2341* =========
2342*
2343* ICTXT (local input) INTEGER
2344* On entry, ICTXT specifies the BLACS context handle, indica-
2345* ting the global context of the operation. The context itself
2346* is global, but the value of ICTXT is local.
2347*
2348* NOUT (global input) INTEGER
2349* On entry, NOUT specifies the unit number for the output file.
2350* When NOUT is 6, output to screen, when NOUT is 0, output to
2351* stderr. NOUT is only defined for process 0.
2352*
2353* NROUT (global input) INTEGER
2354* On entry, NROUT specifies which routine will be tested as
2355* follows:
2356* If NROUT = 1, PZSWAP will be tested;
2357* else if NROUT = 2, PZSCAL will be tested;
2358* else if NROUT = 3, PZDSCAL will be tested;
2359* else if NROUT = 4, PZCOPY will be tested;
2360* else if NROUT = 5, PZAXPY will be tested;
2361* else if NROUT = 6, PZDOTU will be tested;
2362* else if NROUT = 7, PZDOTC will be tested;
2363* else if NROUT = 8, PDZNRM2 will be tested;
2364* else if NROUT = 9, PDZASUM will be tested;
2365* else if NROUT = 10, PZAMAX will be tested.
2366*
2367* N (global input) INTEGER
2368* On entry, N specifies the length of the subvector operands.
2369*
2370* PSCLR (global input) COMPLEX*16
2371* On entry, depending on the value of NROUT, PSCLR specifies
2372* the scalar ALPHA, or the output scalar returned by the PBLAS,
2373* i.e., the dot product, the 2-norm, the absolute sum or the
2374* value of AMAX.
2375*
2376* PUSCLR (global input) DOUBLE PRECISION
2377* On entry, PUSCLR specifies the real part of the scalar ALPHA
2378* used by the real scaling, the 2-norm, or the absolute sum
2379* routines. PUSCLR is not used in the real versions of this
2380* routine.
2381*
2382* PISCLR (global input) DOUBLE PRECISION
2383* On entry, PISCLR specifies the value of the global index re-
2384* turned by PZAMAX, otherwise PISCLR is not used.
2385*
2386* X (local input/local output) COMPLEX*16 array
2387* On entry, X is an array of dimension (DESCX( M_ ),*). This
2388* array contains a local copy of the initial entire matrix PX.
2389*
2390* PX (local input) COMPLEX*16 array
2391* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2392* array contains the local entries of the matrix PX.
2393*
2394* IX (global input) INTEGER
2395* On entry, IX specifies X's global row index, which points to
2396* the beginning of the submatrix sub( X ).
2397*
2398* JX (global input) INTEGER
2399* On entry, JX specifies X's global column index, which points
2400* to the beginning of the submatrix sub( X ).
2401*
2402* DESCX (global and local input) INTEGER array
2403* On entry, DESCX is an integer array of dimension DLEN_. This
2404* is the array descriptor for the matrix X.
2405*
2406* INCX (global input) INTEGER
2407* On entry, INCX specifies the global increment for the
2408* elements of X. Only two values of INCX are supported in
2409* this version, namely 1 and M_X. INCX must not be zero.
2410*
2411* Y (local input/local output) COMPLEX*16 array
2412* On entry, Y is an array of dimension (DESCY( M_ ),*). This
2413* array contains a local copy of the initial entire matrix PY.
2414*
2415* PY (local input) COMPLEX*16 array
2416* On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
2417* array contains the local entries of the matrix PY.
2418*
2419* IY (global input) INTEGER
2420* On entry, IY specifies Y's global row index, which points to
2421* the beginning of the submatrix sub( Y ).
2422*
2423* JY (global input) INTEGER
2424* On entry, JY specifies Y's global column index, which points
2425* to the beginning of the submatrix sub( Y ).
2426*
2427* DESCY (global and local input) INTEGER array
2428* On entry, DESCY is an integer array of dimension DLEN_. This
2429* is the array descriptor for the matrix Y.
2430*
2431* INCY (global input) INTEGER
2432* On entry, INCY specifies the global increment for the
2433* elements of Y. Only two values of INCY are supported in
2434* this version, namely 1 and M_Y. INCY must not be zero.
2435*
2436* INFO (global output) INTEGER
2437* On exit, if INFO = 0, no error has been found, otherwise
2438* if( MOD( INFO, 2 ) = 1 ) then an error on X has been found,
2439* if( MOD( INFO/2, 2 ) = 1 ) then an error on Y has been found.
2440*
2441* -- Written on April 1, 1998 by
2442* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2443*
2444* =====================================================================
2445*
2446* .. Parameters ..
2447 DOUBLE PRECISION RZERO
2448 COMPLEX*16 ZERO
2449 parameter( zero = ( 0.0d+0, 0.0d+0 ),
2450 $ rzero = 0.0d+0 )
2451 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2452 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2453 $ RSRC_
2454 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2455 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2456 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2457 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2458* ..
2459* .. Local Scalars ..
2460 LOGICAL COLREP, INXSCOPE, INYSCOPE, ROWREP
2461 INTEGER I, IB, ICURCOL, ICURROW, IDUMM, IIX, IIY, IN,
2462 $ IOFFX, IOFFY, ISCLR, IXCOL, IXROW, IYCOL,
2463 $ IYROW, J, JB, JJX, JJY, JN, KK, LDX, LDY,
2464 $ MYCOL, MYROW, NPCOL, NPROW
2465 DOUBLE PRECISION ERR, ERRMAX, PREC, USCLR
2466 COMPLEX*16 SCLR
2467* ..
2468* .. Local Arrays ..
2469 INTEGER IERR( 6 )
2470 CHARACTER*5 ARGIN1, ARGIN2, ARGOUT1, ARGOUT2
2471* ..
2472* .. External Subroutines ..
2473 EXTERNAL blacs_gridinfo, igamx2d, pb_infog2l, pzchkvin,
2474 $ pzderrscal, pzerrasum, pzerraxpy, pzerrdotc,
2475 $ pzerrdotu, pzerrnrm2, pzerrscal, zcopy, zswap
2476* ..
2477* .. External Functions ..
2478 LOGICAL PISINSCOPE
2479 INTEGER IZAMAX
2480 DOUBLE PRECISION PDLAMCH
2481 EXTERNAL izamax, pdlamch, pisinscope
2482* ..
2483* .. Intrinsic Functions ..
2484 INTRINSIC min
2485* ..
2486* .. Executable Statements ..
2487*
2488 info = 0
2489*
2490* Quick return if possible
2491*
2492 IF( n.LE.0 )
2493 $ RETURN
2494*
2495 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2496*
2497 argin1 = ' '
2498 argin2 = ' '
2499 argout1 = ' '
2500 argout2 = ' '
2501 DO 10 i = 1, 6
2502 ierr( i ) = 0
2503 10 CONTINUE
2504*
2505 prec = pdlamch( ictxt, 'precision' )
2506*
2507 IF( nrout.EQ.1 ) THEN
2508*
2509* Test PZSWAP
2510*
2511 ioffx = ix + ( jx - 1 ) * descx( m_ )
2512 ioffy = iy + ( jy - 1 ) * descy( m_ )
2513 CALL zswap( n, x( ioffx ), incx, y( ioffy ), incy )
2514 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2515 $ ierr( 1 ) )
2516 CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2517 $ ierr( 2 ) )
2518*
2519 ELSE IF( nrout.EQ.2 ) THEN
2520*
2521* Test PZSCAL
2522*
2523 ldx = descx( lld_ )
2524 ioffx = ix + ( jx - 1 ) * descx( m_ )
2525 CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2526 $ iix, jjx, ixrow, ixcol )
2527 icurrow = ixrow
2528 icurcol = ixcol
2529 rowrep = ( ixrow.EQ.-1 )
2530 colrep = ( ixcol.EQ.-1 )
2531*
2532 IF( incx.EQ.descx( m_ ) ) THEN
2533*
2534* sub( X ) is a row vector
2535*
2536 jb = descx( inb_ ) - jx + 1
2537 IF( jb.LE.0 )
2538 $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2539 jb = min( jb, n )
2540 jn = jx + jb - 1
2541*
2542 DO 20 j = jx, jn
2543*
2544 CALL pzerrscal( err, psclr, x( ioffx ), prec )
2545*
2546 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2547 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2548 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2549 $ err )
2550 $ ierr( 1 ) = 1
2551 jjx = jjx + 1
2552 END IF
2553*
2554 ioffx = ioffx + incx
2555*
2556 20 CONTINUE
2557*
2558 icurcol = mod( icurcol+1, npcol )
2559*
2560 DO 40 j = jn+1, jx+n-1, descx( nb_ )
2561 jb = min( jx+n-j, descx( nb_ ) )
2562*
2563 DO 30 kk = 0, jb-1
2564*
2565 CALL pzerrscal( err, psclr, x( ioffx ), prec )
2566*
2567 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2568 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2569 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2570 $ err )
2571 $ ierr( 1 ) = 1
2572 jjx = jjx + 1
2573 END IF
2574*
2575 ioffx = ioffx + incx
2576*
2577 30 CONTINUE
2578*
2579 icurcol = mod( icurcol+1, npcol )
2580*
2581 40 CONTINUE
2582*
2583 ELSE
2584*
2585* sub( X ) is a column vector
2586*
2587 ib = descx( imb_ ) - ix + 1
2588 IF( ib.LE.0 )
2589 $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2590 ib = min( ib, n )
2591 in = ix + ib - 1
2592*
2593 DO 50 i = ix, in
2594*
2595 CALL pzerrscal( err, psclr, x( ioffx ), prec )
2596*
2597 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2598 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2599 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2600 $ err )
2601 $ ierr( 1 ) = 1
2602 iix = iix + 1
2603 END IF
2604*
2605 ioffx = ioffx + incx
2606*
2607 50 CONTINUE
2608*
2609 icurrow = mod( icurrow+1, nprow )
2610*
2611 DO 70 i = in+1, ix+n-1, descx( mb_ )
2612 ib = min( ix+n-i, descx( mb_ ) )
2613*
2614 DO 60 kk = 0, ib-1
2615*
2616 CALL pzerrscal( err, psclr, x( ioffx ), prec )
2617*
2618 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2619 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2620 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2621 $ err )
2622 $ ierr( 1 ) = 1
2623 iix = iix + 1
2624 END IF
2625*
2626 ioffx = ioffx + incx
2627 60 CONTINUE
2628*
2629 icurrow = mod( icurrow+1, nprow )
2630*
2631 70 CONTINUE
2632*
2633 END IF
2634*
2635 ELSE IF( nrout.EQ.3 ) THEN
2636*
2637* Test PZDSCAL
2638*
2639 ldx = descx( lld_ )
2640 ioffx = ix + ( jx - 1 ) * descx( m_ )
2641 CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2642 $ iix, jjx, ixrow, ixcol )
2643 icurrow = ixrow
2644 icurcol = ixcol
2645 rowrep = ( ixrow.EQ.-1 )
2646 colrep = ( ixcol.EQ.-1 )
2647*
2648 IF( incx.EQ.descx( m_ ) ) THEN
2649*
2650* sub( X ) is a row vector
2651*
2652 jb = descx( inb_ ) - jx + 1
2653 IF( jb.LE.0 )
2654 $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2655 jb = min( jb, n )
2656 jn = jx + jb - 1
2657*
2658 DO 80 j = jx, jn
2659*
2660 CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2661*
2662 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2663 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2664 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2665 $ err )
2666 $ ierr( 1 ) = 1
2667 jjx = jjx + 1
2668 END IF
2669*
2670 ioffx = ioffx + incx
2671*
2672 80 CONTINUE
2673*
2674 icurcol = mod( icurcol+1, npcol )
2675*
2676 DO 100 j = jn+1, jx+n-1, descx( nb_ )
2677 jb = min( jx+n-j, descx( nb_ ) )
2678*
2679 DO 90 kk = 0, jb-1
2680*
2681 CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2682*
2683 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2684 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2685 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2686 $ err )
2687 $ ierr( 1 ) = 1
2688 jjx = jjx + 1
2689 END IF
2690*
2691 ioffx = ioffx + incx
2692*
2693 90 CONTINUE
2694*
2695 icurcol = mod( icurcol+1, npcol )
2696*
2697 100 CONTINUE
2698*
2699 ELSE
2700*
2701* sub( X ) is a column vector
2702*
2703 ib = descx( imb_ ) - ix + 1
2704 IF( ib.LE.0 )
2705 $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2706 ib = min( ib, n )
2707 in = ix + ib - 1
2708*
2709 DO 110 i = ix, in
2710*
2711 CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2712*
2713 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2714 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2715 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2716 $ err )
2717 $ ierr( 1 ) = 1
2718 iix = iix + 1
2719 END IF
2720*
2721 ioffx = ioffx + incx
2722*
2723 110 CONTINUE
2724*
2725 icurrow = mod( icurrow+1, nprow )
2726*
2727 DO 130 i = in+1, ix+n-1, descx( mb_ )
2728 ib = min( ix+n-i, descx( mb_ ) )
2729*
2730 DO 120 kk = 0, ib-1
2731*
2732 CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2733*
2734 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2735 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2736 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2737 $ err )
2738 $ ierr( 1 ) = 1
2739 iix = iix + 1
2740 END IF
2741*
2742 ioffx = ioffx + incx
2743 120 CONTINUE
2744*
2745 icurrow = mod( icurrow+1, nprow )
2746*
2747 130 CONTINUE
2748*
2749 END IF
2750*
2751 ELSE IF( nrout.EQ.4 ) THEN
2752*
2753* Test PZCOPY
2754*
2755 ioffx = ix + ( jx - 1 ) * descx( m_ )
2756 ioffy = iy + ( jy - 1 ) * descy( m_ )
2757 CALL zcopy( n, x( ioffx ), incx, y( ioffy ), incy )
2758 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2759 $ ierr( 1 ) )
2760 CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2761 $ ierr( 2 ) )
2762*
2763 ELSE IF( nrout.EQ.5 ) THEN
2764*
2765* Test PZAXPY
2766*
2767 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2768 $ ierr( 1 ) )
2769 ldy = descy( lld_ )
2770 ioffx = ix + ( jx - 1 ) * descx( m_ )
2771 ioffy = iy + ( jy - 1 ) * descy( m_ )
2772 CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol,
2773 $ iiy, jjy, iyrow, iycol )
2774 icurrow = iyrow
2775 icurcol = iycol
2776 rowrep = ( iyrow.EQ.-1 )
2777 colrep = ( iycol.EQ.-1 )
2778*
2779 IF( incy.EQ.descy( m_ ) ) THEN
2780*
2781* sub( Y ) is a row vector
2782*
2783 jb = descy( inb_ ) - jy + 1
2784 IF( jb.LE.0 )
2785 $ jb = ( (-jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
2786 jb = min( jb, n )
2787 jn = jy + jb - 1
2788*
2789 DO 140 j = jy, jn
2790*
2791 CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2792 $ prec )
2793*
2794 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2795 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2796 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2797 $ err ) THEN
2798 ierr( 2 ) = 1
2799 END IF
2800 jjy = jjy + 1
2801 END IF
2802*
2803 ioffx = ioffx + incx
2804 ioffy = ioffy + incy
2805*
2806 140 CONTINUE
2807*
2808 icurcol = mod( icurcol+1, npcol )
2809*
2810 DO 160 j = jn+1, jy+n-1, descy( nb_ )
2811 jb = min( jy+n-j, descy( nb_ ) )
2812*
2813 DO 150 kk = 0, jb-1
2814*
2815 CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2816 $ prec )
2817*
2818 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2819 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2820 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2821 $ err ) THEN
2822 ierr( 2 ) = 1
2823 END IF
2824 jjy = jjy + 1
2825 END IF
2826*
2827 ioffx = ioffx + incx
2828 ioffy = ioffy + incy
2829*
2830 150 CONTINUE
2831*
2832 icurcol = mod( icurcol+1, npcol )
2833*
2834 160 CONTINUE
2835*
2836 ELSE
2837*
2838* sub( Y ) is a column vector
2839*
2840 ib = descy( imb_ ) - iy + 1
2841 IF( ib.LE.0 )
2842 $ ib = ( (-ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
2843 ib = min( ib, n )
2844 in = iy + ib - 1
2845*
2846 DO 170 i = iy, in
2847*
2848 CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2849 $ prec )
2850*
2851 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2852 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2853 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2854 $ err ) THEN
2855 ierr( 2 ) = 1
2856 END IF
2857 iiy = iiy + 1
2858 END IF
2859*
2860 ioffx = ioffx + incx
2861 ioffy = ioffy + incy
2862*
2863 170 CONTINUE
2864*
2865 icurrow = mod( icurrow+1, nprow )
2866*
2867 DO 190 i = in+1, iy+n-1, descy( mb_ )
2868 ib = min( iy+n-i, descy( mb_ ) )
2869*
2870 DO 180 kk = 0, ib-1
2871*
2872 CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2873 $ prec )
2874*
2875 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2876 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2877 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2878 $ err ) THEN
2879 ierr( 2 ) = 1
2880 END IF
2881 iiy = iiy + 1
2882 END IF
2883*
2884 ioffx = ioffx + incx
2885 ioffy = ioffy + incy
2886*
2887 180 CONTINUE
2888*
2889 icurrow = mod( icurrow+1, nprow )
2890*
2891 190 CONTINUE
2892*
2893 END IF
2894*
2895 ELSE IF( nrout.EQ.6 ) THEN
2896*
2897* Test PZDOTU
2898*
2899 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2900 $ ierr( 1 ) )
2901 CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2902 $ ierr( 2 ) )
2903 ioffx = ix + ( jx - 1 ) * descx( m_ )
2904 ioffy = iy + ( jy - 1 ) * descy( m_ )
2905 CALL pzerrdotu( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2906 $ incy, prec )
2907 inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2908 inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2909 IF( inxscope.OR.inyscope ) THEN
2910 IF( abs( psclr - sclr ).GT.err ) THEN
2911 ierr( 3 ) = 1
2912 WRITE( argin1, fmt = '(A)' ) 'DOTU'
2913 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2914 WRITE( nout, fmt = 9998 ) argin1
2915 WRITE( nout, fmt = 9996 ) sclr, psclr
2916 END IF
2917 END IF
2918 ELSE
2919 sclr = zero
2920 IF( psclr.NE.sclr ) THEN
2921 ierr( 4 ) = 1
2922 WRITE( argout1, fmt = '(A)' ) 'DOTU'
2923 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2924 WRITE( nout, fmt = 9997 ) argout1
2925 WRITE( nout, fmt = 9996 ) sclr, psclr
2926 END IF
2927 END IF
2928 END IF
2929*
2930 ELSE IF( nrout.EQ.7 ) THEN
2931*
2932* Test PZDOTC
2933*
2934 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2935 $ ierr( 1 ) )
2936 CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2937 $ ierr( 2 ) )
2938 ioffx = ix + ( jx - 1 ) * descx( m_ )
2939 ioffy = iy + ( jy - 1 ) * descy( m_ )
2940 CALL pzerrdotc( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2941 $ incy, prec )
2942 inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2943 inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2944 IF( inxscope.OR.inyscope ) THEN
2945 IF( abs( psclr - sclr ).GT.err ) THEN
2946 ierr( 3 ) = 1
2947 WRITE( argin1, fmt = '(A)' ) 'DOTC'
2948 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2949 WRITE( nout, fmt = 9998 ) argin1
2950 WRITE( nout, fmt = 9996 ) sclr, psclr
2951 END IF
2952 END IF
2953 ELSE
2954 sclr = zero
2955 IF( psclr.NE.sclr ) THEN
2956 ierr( 4 ) = 1
2957 WRITE( argout1, fmt = '(A)' ) 'DOTC'
2958 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2959 WRITE( nout, fmt = 9997 ) argout1
2960 WRITE( nout, fmt = 9996 ) sclr, psclr
2961 END IF
2962 END IF
2963 END IF
2964*
2965 ELSE IF( nrout.EQ.8 ) THEN
2966*
2967* Test PDZNRM2
2968*
2969 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2970 $ ierr( 1 ) )
2971 ioffx = ix + ( jx - 1 ) * descx( m_ )
2972 CALL pzerrnrm2( err, n, usclr, x( ioffx ), incx, prec )
2973 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2974 IF( abs( pusclr - usclr ).GT.err ) THEN
2975 ierr( 3 ) = 1
2976 WRITE( argin1, fmt = '(A)' ) 'NRM2'
2977 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2978 WRITE( nout, fmt = 9998 ) argin1
2979 WRITE( nout, fmt = 9994 ) usclr, pusclr
2980 END IF
2981 END IF
2982 ELSE
2983 usclr = rzero
2984 IF( pusclr.NE.usclr ) THEN
2985 ierr( 4 ) = 1
2986 WRITE( argout1, fmt = '(A)' ) 'NRM2'
2987 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2988 WRITE( nout, fmt = 9997 ) argout1
2989 WRITE( nout, fmt = 9994 ) usclr, pusclr
2990 END IF
2991 END IF
2992 END IF
2993*
2994 ELSE IF( nrout.EQ.9 ) THEN
2995*
2996* Test PDZASUM
2997*
2998 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2999 $ ierr( 1 ) )
3000 ioffx = ix + ( jx - 1 ) * descx( m_ )
3001 CALL pzerrasum( err, n, usclr, x( ioffx ), incx, prec )
3002 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3003 IF( abs( pusclr - usclr ) .GT. err ) THEN
3004 ierr( 3 ) = 1
3005 WRITE( argin1, fmt = '(A)' ) 'ASUM'
3006 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3007 WRITE( nout, fmt = 9998 ) argin1
3008 WRITE( nout, fmt = 9994 ) usclr, pusclr
3009 END IF
3010 END IF
3011 ELSE
3012 usclr = rzero
3013 IF( pusclr.NE.usclr ) THEN
3014 ierr( 4 ) = 1
3015 WRITE( argout1, fmt = '(A)' ) 'ASUM'
3016 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3017 WRITE( nout, fmt = 9997 ) argout1
3018 WRITE( nout, fmt = 9994 ) usclr, pusclr
3019 END IF
3020 END IF
3021 END IF
3022*
3023 ELSE IF( nrout.EQ.10 ) THEN
3024*
3025* Test PZAMAX
3026*
3027 CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
3028 $ ierr( 1 ) )
3029 ioffx = ix + ( jx - 1 ) * descx( m_ )
3030 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3031 isclr = izamax( n, x( ioffx ), incx )
3032 IF( n.LT.1 ) THEN
3033 sclr = zero
3034 ELSE IF( ( incx.EQ.1 ).AND.( descx( m_ ).EQ.1 ).AND.
3035 $ ( n.EQ.1 ) ) THEN
3036 isclr = jx
3037 sclr = x( ioffx )
3038 ELSE IF( incx.EQ.descx( m_ ) ) THEN
3039 isclr = jx + isclr - 1
3040 sclr = x( ix + ( isclr - 1 ) * descx( m_ ) )
3041 ELSE
3042 isclr = ix + isclr - 1
3043 sclr = x( isclr + ( jx - 1 ) * descx( m_ ) )
3044 END IF
3045*
3046 IF( psclr.NE.sclr ) THEN
3047 ierr( 3 ) = 1
3048 WRITE( argin1, fmt = '(A)' ) 'AMAX'
3049 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3050 WRITE( nout, fmt = 9998 ) argin1
3051 WRITE( nout, fmt = 9996 ) sclr, psclr
3052 END IF
3053 END IF
3054*
3055 IF( pisclr.NE.isclr ) THEN
3056 ierr( 5 ) = 1
3057 WRITE( argin2, fmt = '(A)' ) 'INDX'
3058 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3059 WRITE( nout, fmt = 9998 ) argin2
3060 WRITE( nout, fmt = 9995 ) isclr, pisclr
3061 END IF
3062 END IF
3063 ELSE
3064 isclr = 0
3065 sclr = zero
3066 IF( psclr.NE.sclr ) THEN
3067 ierr( 4 ) = 1
3068 WRITE( argout1, fmt = '(A)' ) 'AMAX'
3069 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3070 WRITE( nout, fmt = 9997 ) argout1
3071 WRITE( nout, fmt = 9996 ) sclr, psclr
3072 END IF
3073 END IF
3074 IF( pisclr.NE.isclr ) THEN
3075 ierr( 6 ) = 1
3076 WRITE( argout2, fmt = '(A)' ) 'INDX'
3077 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3078 WRITE( nout, fmt = 9997 ) argout2
3079 WRITE( nout, fmt = 9995 ) isclr, pisclr
3080 END IF
3081 END IF
3082 END IF
3083*
3084 END IF
3085*
3086* Find IERR across all processes
3087*
3088 CALL igamx2d( ictxt, 'All', ' ', 6, 1, ierr, 6, idumm, idumm, -1,
3089 $ -1, 0 )
3090*
3091* Encode the errors found in INFO
3092*
3093 IF( ierr( 1 ).NE.0 ) THEN
3094 info = info + 1
3095 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3096 $ WRITE( nout, fmt = 9999 ) 'X'
3097 END IF
3098*
3099 IF( ierr( 2 ).NE.0 ) THEN
3100 info = info + 2
3101 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3102 $ WRITE( nout, fmt = 9999 ) 'Y'
3103 END IF
3104*
3105 IF( ierr( 3 ).NE.0 )
3106 $ info = info + 4
3107*
3108 IF( ierr( 4 ).NE.0 )
3109 $ info = info + 8
3110*
3111 IF( ierr( 5 ).NE.0 )
3112 $ info = info + 16
3113*
3114 IF( ierr( 6 ).NE.0 )
3115 $ info = info + 32
3116*
3117 9999 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
3118 $ ' is incorrect.' )
3119 9998 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3120 $ ' in scope is incorrect.' )
3121 9997 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3122 $ ' out of scope is incorrect.' )
3123 9996 FORMAT( 2x, ' ***** Expected value is: ', d30.18, '+i*(',
3124 $ d30.18, '),', /2x, ' Obtained value is: ',
3125 $ d30.18, '+i*(', d30.18, ')' )
3126 9995 FORMAT( 2x, ' ***** Expected value is: ', i6, /2x,
3127 $ ' Obtained value is: ', i6 )
3128 9994 FORMAT( 2x, ' ***** Expected value is: ', d30.18, /2x,
3129 $ ' Obtained value is: ', d30.18 )
3130*
3131 RETURN
3132*
3133* End of PZBLAS1TSTCHK
3134*
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
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
pzerrdotu
subroutine pzerrdotu(errbnd, n, sclr, x, incx, y, incy, prec)
Definition pzblas1tst.f:3137
pzerraxpy
subroutine pzerraxpy(errbnd, psclr, x, y, prec)
Definition pzblas1tst.f:3777
pzderrscal
subroutine pzderrscal(errbnd, pusclr, x, prec)
Definition pzblas1tst.f:3709
pzerrdotc
subroutine pzerrdotc(errbnd, n, sclr, x, incx, y, incy, prec)
Definition pzblas1tst.f:3281
pzerrasum
subroutine pzerrasum(errbnd, n, usclr, x, incx, prec)
Definition pzblas1tst.f:3558
pzerrscal
subroutine pzerrscal(errbnd, psclr, x, prec)
Definition pzblas1tst.f:3641
pzerrnrm2
subroutine pzerrnrm2(errbnd, n, usclr, x, incx, prec)
Definition pzblas1tst.f:3425
pzchkvin
subroutine pzchkvin(errmax, n, x, px, ix, jx, descx, incx, info)
Definition pzblastst.f:2582
Here is the call graph for this function:
Here is the caller graph for this function: