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

◆ pcblas1tstchk()

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

Definition at line 2252 of file pcblas1tst.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 REAL PUSCLR
2265 COMPLEX PSCLR
2266* ..
2267* .. Array Arguments ..
2268 INTEGER DESCX( * ), DESCY( * )
2269 COMPLEX PX( * ), PY( * ), X( * ), Y( * )
2270* ..
2271*
2272* Purpose
2273* =======
2274*
2275* PCBLAS1TSTCHK 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, PCSWAP will be tested;
2357* else if NROUT = 2, PCSCAL will be tested;
2358* else if NROUT = 3, PCSSCAL will be tested;
2359* else if NROUT = 4, PCCOPY will be tested;
2360* else if NROUT = 5, PCAXPY will be tested;
2361* else if NROUT = 6, PCDOTU will be tested;
2362* else if NROUT = 7, PCDOTC will be tested;
2363* else if NROUT = 8, PSCNRM2 will be tested;
2364* else if NROUT = 9, PSCASUM will be tested;
2365* else if NROUT = 10, PCAMAX 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
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) REAL
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) REAL
2383* On entry, PISCLR specifies the value of the global index re-
2384* turned by PCAMAX, otherwise PISCLR is not used.
2385*
2386* X (local input/local output) COMPLEX 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 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 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 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 REAL RZERO
2448 COMPLEX ZERO
2449 parameter( zero = ( 0.0e+0, 0.0e+0 ),
2450 $ rzero = 0.0e+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 REAL ERR, ERRMAX, PREC, USCLR
2466 COMPLEX SCLR
2467* ..
2468* .. Local Arrays ..
2469 INTEGER IERR( 6 )
2470 CHARACTER*5 ARGIN1, ARGIN2, ARGOUT1, ARGOUT2
2471* ..
2472* .. External Subroutines ..
2473 EXTERNAL blacs_gridinfo, ccopy, cswap, igamx2d,
2474 $ pb_infog2l, pcchkvin, pcerrasum, pcerraxpy,
2475 $ pcerrdotc, pcerrdotu, pcerrnrm2, pcerrscal,
2476 $ pcserrscal
2477* ..
2478* .. External Functions ..
2479 LOGICAL PISINSCOPE
2480 INTEGER ICAMAX
2481 REAL PSLAMCH
2482 EXTERNAL icamax, pisinscope, pslamch
2483* ..
2484* .. Intrinsic Functions ..
2485 INTRINSIC min
2486* ..
2487* .. Executable Statements ..
2488*
2489 info = 0
2490*
2491* Quick return if possible
2492*
2493 IF( n.LE.0 )
2494 $ RETURN
2495*
2496 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2497*
2498 argin1 = ' '
2499 argin2 = ' '
2500 argout1 = ' '
2501 argout2 = ' '
2502 DO 10 i = 1, 6
2503 ierr( i ) = 0
2504 10 CONTINUE
2505*
2506 prec = pslamch( ictxt, 'precision' )
2507*
2508 IF( nrout.EQ.1 ) THEN
2509*
2510* Test PCSWAP
2511*
2512 ioffx = ix + ( jx - 1 ) * descx( m_ )
2513 ioffy = iy + ( jy - 1 ) * descy( m_ )
2514 CALL cswap( n, x( ioffx ), incx, y( ioffy ), incy )
2515 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2516 $ ierr( 1 ) )
2517 CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2518 $ ierr( 2 ) )
2519*
2520 ELSE IF( nrout.EQ.2 ) THEN
2521*
2522* Test PCSCAL
2523*
2524 ldx = descx( lld_ )
2525 ioffx = ix + ( jx - 1 ) * descx( m_ )
2526 CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2527 $ iix, jjx, ixrow, ixcol )
2528 icurrow = ixrow
2529 icurcol = ixcol
2530 rowrep = ( ixrow.EQ.-1 )
2531 colrep = ( ixcol.EQ.-1 )
2532*
2533 IF( incx.EQ.descx( m_ ) ) THEN
2534*
2535* sub( X ) is a row vector
2536*
2537 jb = descx( inb_ ) - jx + 1
2538 IF( jb.LE.0 )
2539 $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2540 jb = min( jb, n )
2541 jn = jx + jb - 1
2542*
2543 DO 20 j = jx, jn
2544*
2545 CALL pcerrscal( 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 jjx = jjx + 1
2553 END IF
2554*
2555 ioffx = ioffx + incx
2556*
2557 20 CONTINUE
2558*
2559 icurcol = mod( icurcol+1, npcol )
2560*
2561 DO 40 j = jn+1, jx+n-1, descx( nb_ )
2562 jb = min( jx+n-j, descx( nb_ ) )
2563*
2564 DO 30 kk = 0, jb-1
2565*
2566 CALL pcerrscal( 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 jjx = jjx + 1
2574 END IF
2575*
2576 ioffx = ioffx + incx
2577*
2578 30 CONTINUE
2579*
2580 icurcol = mod( icurcol+1, npcol )
2581*
2582 40 CONTINUE
2583*
2584 ELSE
2585*
2586* sub( X ) is a column vector
2587*
2588 ib = descx( imb_ ) - ix + 1
2589 IF( ib.LE.0 )
2590 $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2591 ib = min( ib, n )
2592 in = ix + ib - 1
2593*
2594 DO 50 i = ix, in
2595*
2596 CALL pcerrscal( err, psclr, x( ioffx ), prec )
2597*
2598 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2599 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2600 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2601 $ err )
2602 $ ierr( 1 ) = 1
2603 iix = iix + 1
2604 END IF
2605*
2606 ioffx = ioffx + incx
2607*
2608 50 CONTINUE
2609*
2610 icurrow = mod( icurrow+1, nprow )
2611*
2612 DO 70 i = in+1, ix+n-1, descx( mb_ )
2613 ib = min( ix+n-i, descx( mb_ ) )
2614*
2615 DO 60 kk = 0, ib-1
2616*
2617 CALL pcerrscal( err, psclr, x( ioffx ), prec )
2618*
2619 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2620 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2621 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2622 $ err )
2623 $ ierr( 1 ) = 1
2624 iix = iix + 1
2625 END IF
2626*
2627 ioffx = ioffx + incx
2628 60 CONTINUE
2629*
2630 icurrow = mod( icurrow+1, nprow )
2631*
2632 70 CONTINUE
2633*
2634 END IF
2635*
2636 ELSE IF( nrout.EQ.3 ) THEN
2637*
2638* Test PCSSCAL
2639*
2640 ldx = descx( lld_ )
2641 ioffx = ix + ( jx - 1 ) * descx( m_ )
2642 CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2643 $ iix, jjx, ixrow, ixcol )
2644 icurrow = ixrow
2645 icurcol = ixcol
2646 rowrep = ( ixrow.EQ.-1 )
2647 colrep = ( ixcol.EQ.-1 )
2648*
2649 IF( incx.EQ.descx( m_ ) ) THEN
2650*
2651* sub( X ) is a row vector
2652*
2653 jb = descx( inb_ ) - jx + 1
2654 IF( jb.LE.0 )
2655 $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2656 jb = min( jb, n )
2657 jn = jx + jb - 1
2658*
2659 DO 80 j = jx, jn
2660*
2661 CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2662*
2663 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2664 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2665 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2666 $ err )
2667 $ ierr( 1 ) = 1
2668 jjx = jjx + 1
2669 END IF
2670*
2671 ioffx = ioffx + incx
2672*
2673 80 CONTINUE
2674*
2675 icurcol = mod( icurcol+1, npcol )
2676*
2677 DO 100 j = jn+1, jx+n-1, descx( nb_ )
2678 jb = min( jx+n-j, descx( nb_ ) )
2679*
2680 DO 90 kk = 0, jb-1
2681*
2682 CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2683*
2684 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2685 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2686 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2687 $ err )
2688 $ ierr( 1 ) = 1
2689 jjx = jjx + 1
2690 END IF
2691*
2692 ioffx = ioffx + incx
2693*
2694 90 CONTINUE
2695*
2696 icurcol = mod( icurcol+1, npcol )
2697*
2698 100 CONTINUE
2699*
2700 ELSE
2701*
2702* sub( X ) is a column vector
2703*
2704 ib = descx( imb_ ) - ix + 1
2705 IF( ib.LE.0 )
2706 $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2707 ib = min( ib, n )
2708 in = ix + ib - 1
2709*
2710 DO 110 i = ix, in
2711*
2712 CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2713*
2714 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2715 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2716 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2717 $ err )
2718 $ ierr( 1 ) = 1
2719 iix = iix + 1
2720 END IF
2721*
2722 ioffx = ioffx + incx
2723*
2724 110 CONTINUE
2725*
2726 icurrow = mod( icurrow+1, nprow )
2727*
2728 DO 130 i = in+1, ix+n-1, descx( mb_ )
2729 ib = min( ix+n-i, descx( mb_ ) )
2730*
2731 DO 120 kk = 0, ib-1
2732*
2733 CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2734*
2735 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2736 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2737 IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2738 $ err )
2739 $ ierr( 1 ) = 1
2740 iix = iix + 1
2741 END IF
2742*
2743 ioffx = ioffx + incx
2744 120 CONTINUE
2745*
2746 icurrow = mod( icurrow+1, nprow )
2747*
2748 130 CONTINUE
2749*
2750 END IF
2751*
2752 ELSE IF( nrout.EQ.4 ) THEN
2753*
2754* Test PCCOPY
2755*
2756 ioffx = ix + ( jx - 1 ) * descx( m_ )
2757 ioffy = iy + ( jy - 1 ) * descy( m_ )
2758 CALL ccopy( n, x( ioffx ), incx, y( ioffy ), incy )
2759 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2760 $ ierr( 1 ) )
2761 CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2762 $ ierr( 2 ) )
2763*
2764 ELSE IF( nrout.EQ.5 ) THEN
2765*
2766* Test PCAXPY
2767*
2768 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2769 $ ierr( 1 ) )
2770 ldy = descy( lld_ )
2771 ioffx = ix + ( jx - 1 ) * descx( m_ )
2772 ioffy = iy + ( jy - 1 ) * descy( m_ )
2773 CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol,
2774 $ iiy, jjy, iyrow, iycol )
2775 icurrow = iyrow
2776 icurcol = iycol
2777 rowrep = ( iyrow.EQ.-1 )
2778 colrep = ( iycol.EQ.-1 )
2779*
2780 IF( incy.EQ.descy( m_ ) ) THEN
2781*
2782* sub( Y ) is a row vector
2783*
2784 jb = descy( inb_ ) - jy + 1
2785 IF( jb.LE.0 )
2786 $ jb = ( (-jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
2787 jb = min( jb, n )
2788 jn = jy + jb - 1
2789*
2790 DO 140 j = jy, jn
2791*
2792 CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2793 $ prec )
2794*
2795 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2796 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2797 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2798 $ err ) THEN
2799 ierr( 2 ) = 1
2800 END IF
2801 jjy = jjy + 1
2802 END IF
2803*
2804 ioffx = ioffx + incx
2805 ioffy = ioffy + incy
2806*
2807 140 CONTINUE
2808*
2809 icurcol = mod( icurcol+1, npcol )
2810*
2811 DO 160 j = jn+1, jy+n-1, descy( nb_ )
2812 jb = min( jy+n-j, descy( nb_ ) )
2813*
2814 DO 150 kk = 0, jb-1
2815*
2816 CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2817 $ prec )
2818*
2819 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2820 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2821 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2822 $ err ) THEN
2823 ierr( 2 ) = 1
2824 END IF
2825 jjy = jjy + 1
2826 END IF
2827*
2828 ioffx = ioffx + incx
2829 ioffy = ioffy + incy
2830*
2831 150 CONTINUE
2832*
2833 icurcol = mod( icurcol+1, npcol )
2834*
2835 160 CONTINUE
2836*
2837 ELSE
2838*
2839* sub( Y ) is a column vector
2840*
2841 ib = descy( imb_ ) - iy + 1
2842 IF( ib.LE.0 )
2843 $ ib = ( (-ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
2844 ib = min( ib, n )
2845 in = iy + ib - 1
2846*
2847 DO 170 i = iy, in
2848*
2849 CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2850 $ prec )
2851*
2852 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2853 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2854 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2855 $ err ) THEN
2856 ierr( 2 ) = 1
2857 END IF
2858 iiy = iiy + 1
2859 END IF
2860*
2861 ioffx = ioffx + incx
2862 ioffy = ioffy + incy
2863*
2864 170 CONTINUE
2865*
2866 icurrow = mod( icurrow+1, nprow )
2867*
2868 DO 190 i = in+1, iy+n-1, descy( mb_ )
2869 ib = min( iy+n-i, descy( mb_ ) )
2870*
2871 DO 180 kk = 0, ib-1
2872*
2873 CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2874 $ prec )
2875*
2876 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2877 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2878 IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2879 $ err ) THEN
2880 ierr( 2 ) = 1
2881 END IF
2882 iiy = iiy + 1
2883 END IF
2884*
2885 ioffx = ioffx + incx
2886 ioffy = ioffy + incy
2887*
2888 180 CONTINUE
2889*
2890 icurrow = mod( icurrow+1, nprow )
2891*
2892 190 CONTINUE
2893*
2894 END IF
2895*
2896 ELSE IF( nrout.EQ.6 ) THEN
2897*
2898* Test PCDOTU
2899*
2900 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2901 $ ierr( 1 ) )
2902 CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2903 $ ierr( 2 ) )
2904 ioffx = ix + ( jx - 1 ) * descx( m_ )
2905 ioffy = iy + ( jy - 1 ) * descy( m_ )
2906 CALL pcerrdotu( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2907 $ incy, prec )
2908 inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2909 inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2910 IF( inxscope.OR.inyscope ) THEN
2911 IF( abs( psclr - sclr ).GT.err ) THEN
2912 ierr( 3 ) = 1
2913 WRITE( argin1, fmt = '(A)' ) 'DOTU'
2914 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2915 WRITE( nout, fmt = 9998 ) argin1
2916 WRITE( nout, fmt = 9996 ) sclr, psclr
2917 END IF
2918 END IF
2919 ELSE
2920 sclr = zero
2921 IF( psclr.NE.sclr ) THEN
2922 ierr( 4 ) = 1
2923 WRITE( argout1, fmt = '(A)' ) 'DOTU'
2924 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2925 WRITE( nout, fmt = 9997 ) argout1
2926 WRITE( nout, fmt = 9996 ) sclr, psclr
2927 END IF
2928 END IF
2929 END IF
2930*
2931 ELSE IF( nrout.EQ.7 ) THEN
2932*
2933* Test PCDOTC
2934*
2935 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2936 $ ierr( 1 ) )
2937 CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2938 $ ierr( 2 ) )
2939 ioffx = ix + ( jx - 1 ) * descx( m_ )
2940 ioffy = iy + ( jy - 1 ) * descy( m_ )
2941 CALL pcerrdotc( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2942 $ incy, prec )
2943 inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2944 inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2945 IF( inxscope.OR.inyscope ) THEN
2946 IF( abs( psclr - sclr ).GT.err ) THEN
2947 ierr( 3 ) = 1
2948 WRITE( argin1, fmt = '(A)' ) 'DOTC'
2949 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2950 WRITE( nout, fmt = 9998 ) argin1
2951 WRITE( nout, fmt = 9996 ) sclr, psclr
2952 END IF
2953 END IF
2954 ELSE
2955 sclr = zero
2956 IF( psclr.NE.sclr ) THEN
2957 ierr( 4 ) = 1
2958 WRITE( argout1, fmt = '(A)' ) 'DOTC'
2959 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2960 WRITE( nout, fmt = 9997 ) argout1
2961 WRITE( nout, fmt = 9996 ) sclr, psclr
2962 END IF
2963 END IF
2964 END IF
2965*
2966 ELSE IF( nrout.EQ.8 ) THEN
2967*
2968* Test PSCNRM2
2969*
2970 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2971 $ ierr( 1 ) )
2972 ioffx = ix + ( jx - 1 ) * descx( m_ )
2973 CALL pcerrnrm2( err, n, usclr, x( ioffx ), incx, prec )
2974 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2975 IF( abs( pusclr - usclr ).GT.err ) THEN
2976 ierr( 3 ) = 1
2977 WRITE( argin1, fmt = '(A)' ) 'NRM2'
2978 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2979 WRITE( nout, fmt = 9998 ) argin1
2980 WRITE( nout, fmt = 9994 ) usclr, pusclr
2981 END IF
2982 END IF
2983 ELSE
2984 usclr = rzero
2985 IF( pusclr.NE.usclr ) THEN
2986 ierr( 4 ) = 1
2987 WRITE( argout1, fmt = '(A)' ) 'NRM2'
2988 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2989 WRITE( nout, fmt = 9997 ) argout1
2990 WRITE( nout, fmt = 9994 ) usclr, pusclr
2991 END IF
2992 END IF
2993 END IF
2994*
2995 ELSE IF( nrout.EQ.9 ) THEN
2996*
2997* Test PSCASUM
2998*
2999 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
3000 $ ierr( 1 ) )
3001 ioffx = ix + ( jx - 1 ) * descx( m_ )
3002 CALL pcerrasum( err, n, usclr, x( ioffx ), incx, prec )
3003 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3004 IF( abs( pusclr - usclr ) .GT. err ) THEN
3005 ierr( 3 ) = 1
3006 WRITE( argin1, fmt = '(A)' ) 'ASUM'
3007 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3008 WRITE( nout, fmt = 9998 ) argin1
3009 WRITE( nout, fmt = 9994 ) usclr, pusclr
3010 END IF
3011 END IF
3012 ELSE
3013 usclr = rzero
3014 IF( pusclr.NE.usclr ) THEN
3015 ierr( 4 ) = 1
3016 WRITE( argout1, fmt = '(A)' ) 'ASUM'
3017 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3018 WRITE( nout, fmt = 9997 ) argout1
3019 WRITE( nout, fmt = 9994 ) usclr, pusclr
3020 END IF
3021 END IF
3022 END IF
3023*
3024 ELSE IF( nrout.EQ.10 ) THEN
3025*
3026* Test PCAMAX
3027*
3028 CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
3029 $ ierr( 1 ) )
3030 ioffx = ix + ( jx - 1 ) * descx( m_ )
3031 IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3032 isclr = icamax( n, x( ioffx ), incx )
3033 IF( n.LT.1 ) THEN
3034 sclr = zero
3035 ELSE IF( ( incx.EQ.1 ).AND.( descx( m_ ).EQ.1 ).AND.
3036 $ ( n.EQ.1 ) ) THEN
3037 isclr = jx
3038 sclr = x( ioffx )
3039 ELSE IF( incx.EQ.descx( m_ ) ) THEN
3040 isclr = jx + isclr - 1
3041 sclr = x( ix + ( isclr - 1 ) * descx( m_ ) )
3042 ELSE
3043 isclr = ix + isclr - 1
3044 sclr = x( isclr + ( jx - 1 ) * descx( m_ ) )
3045 END IF
3046*
3047 IF( psclr.NE.sclr ) THEN
3048 ierr( 3 ) = 1
3049 WRITE( argin1, fmt = '(A)' ) 'AMAX'
3050 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3051 WRITE( nout, fmt = 9998 ) argin1
3052 WRITE( nout, fmt = 9996 ) sclr, psclr
3053 END IF
3054 END IF
3055*
3056 IF( pisclr.NE.isclr ) THEN
3057 ierr( 5 ) = 1
3058 WRITE( argin2, fmt = '(A)' ) 'INDX'
3059 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3060 WRITE( nout, fmt = 9998 ) argin2
3061 WRITE( nout, fmt = 9995 ) isclr, pisclr
3062 END IF
3063 END IF
3064 ELSE
3065 isclr = 0
3066 sclr = zero
3067 IF( psclr.NE.sclr ) THEN
3068 ierr( 4 ) = 1
3069 WRITE( argout1, fmt = '(A)' ) 'AMAX'
3070 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3071 WRITE( nout, fmt = 9997 ) argout1
3072 WRITE( nout, fmt = 9996 ) sclr, psclr
3073 END IF
3074 END IF
3075 IF( pisclr.NE.isclr ) THEN
3076 ierr( 6 ) = 1
3077 WRITE( argout2, fmt = '(A)' ) 'INDX'
3078 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3079 WRITE( nout, fmt = 9997 ) argout2
3080 WRITE( nout, fmt = 9995 ) isclr, pisclr
3081 END IF
3082 END IF
3083 END IF
3084*
3085 END IF
3086*
3087* Find IERR across all processes
3088*
3089 CALL igamx2d( ictxt, 'All', ' ', 6, 1, ierr, 6, idumm, idumm, -1,
3090 $ -1, 0 )
3091*
3092* Encode the errors found in INFO
3093*
3094 IF( ierr( 1 ).NE.0 ) THEN
3095 info = info + 1
3096 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3097 $ WRITE( nout, fmt = 9999 ) 'X'
3098 END IF
3099*
3100 IF( ierr( 2 ).NE.0 ) THEN
3101 info = info + 2
3102 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3103 $ WRITE( nout, fmt = 9999 ) 'Y'
3104 END IF
3105*
3106 IF( ierr( 3 ).NE.0 )
3107 $ info = info + 4
3108*
3109 IF( ierr( 4 ).NE.0 )
3110 $ info = info + 8
3111*
3112 IF( ierr( 5 ).NE.0 )
3113 $ info = info + 16
3114*
3115 IF( ierr( 6 ).NE.0 )
3116 $ info = info + 32
3117*
3118 9999 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
3119 $ ' is incorrect.' )
3120 9998 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3121 $ ' in scope is incorrect.' )
3122 9997 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3123 $ ' out of scope is incorrect.' )
3124 9996 FORMAT( 2x, ' ***** Expected value is: ', e16.8, '+i*(',
3125 $ e16.8, '),', /2x, ' Obtained value is: ',
3126 $ e16.8, '+i*(', e16.8, ')' )
3127 9995 FORMAT( 2x, ' ***** Expected value is: ', i6, /2x,
3128 $ ' Obtained value is: ', i6 )
3129 9994 FORMAT( 2x, ' ***** Expected value is: ', e16.8, /2x,
3130 $ ' Obtained value is: ', e16.8 )
3131*
3132 RETURN
3133*
3134* End of PCBLAS1TSTCHK
3135*
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pcerrnrm2
subroutine pcerrnrm2(errbnd, n, usclr, x, incx, prec)
Definition pcblas1tst.f:3426
pcserrscal
subroutine pcserrscal(errbnd, pusclr, x, prec)
Definition pcblas1tst.f:3710
pcerrdotu
subroutine pcerrdotu(errbnd, n, sclr, x, incx, y, incy, prec)
Definition pcblas1tst.f:3138
pcerrscal
subroutine pcerrscal(errbnd, psclr, x, prec)
Definition pcblas1tst.f:3642
pcerrdotc
subroutine pcerrdotc(errbnd, n, sclr, x, incx, y, incy, prec)
Definition pcblas1tst.f:3282
pisinscope
logical function pisinscope(ictxt, n, ix, jx, descx, incx)
Definition pcblas1tst.f:2078
pcerraxpy
subroutine pcerraxpy(errbnd, psclr, x, y, prec)
Definition pcblas1tst.f:3778
pcerrasum
subroutine pcerrasum(errbnd, n, usclr, x, incx, prec)
Definition pcblas1tst.f:3559
pcchkvin
subroutine pcchkvin(errmax, n, x, px, ix, jx, descx, incx, info)
Definition pcblastst.f:2582
pslamch
real function pslamch(ictxt, cmach)
Definition pcblastst.f:7455
min
#define min(A, B)
Definition pcgemr.c:181
Here is the call graph for this function:
Here is the caller graph for this function: