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

◆ ssdrvtest()

subroutine ssdrvtest ( integer  outnum,
integer  verb,
integer  nshape,
character*1, dimension(nshape)  uplo0,
character*1, dimension(nshape)  diag0,
integer  nmat,
integer, dimension(nmat)  m0,
integer, dimension(nmat)  n0,
integer, dimension(nmat)  ldas0,
integer, dimension(nmat)  ldad0,
integer  nsrc,
integer, dimension(nsrc)  rsrc0,
integer, dimension(nsrc)  csrc0,
integer, dimension(nsrc)  rdest0,
integer, dimension(nsrc)  cdest0,
integer  ngrid,
integer, dimension(ngrid)  context0,
integer, dimension(ngrid)  p0,
integer, dimension(ngrid)  q0,
integer, dimension(*)  tfail,
real, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 2545 of file blacstest.f.

2549*
2550* -- BLACS tester (version 1.0) --
2551* University of Tennessee
2552* December 15, 1994
2553*
2554*
2555* .. Scalar Arguments ..
2556 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2557* ..
2558* .. Array Arguments ..
2559 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2560 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2561 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2562 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2563 REAL MEM(MEMLEN)
2564* ..
2565*
2566* Purpose
2567* =======
2568* STESTSDRV: Test real send/recv
2569*
2570* Arguments
2571* =========
2572* OUTNUM (input) INTEGER
2573* The device number to write output to.
2574*
2575* VERB (input) INTEGER
2576* The level of verbosity (how much printing to do).
2577*
2578* NSHAPE (input) INTEGER
2579* The number of matrix shapes to be tested.
2580*
2581* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2582* Values of UPLO to be tested.
2583*
2584* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2585* Values of DIAG to be tested.
2586*
2587* NMAT (input) INTEGER
2588* The number of matrices to be tested.
2589*
2590* M0 (input) INTEGER array of dimension (NMAT)
2591* Values of M to be tested.
2592*
2593* M0 (input) INTEGER array of dimension (NMAT)
2594* Values of M to be tested.
2595*
2596* N0 (input) INTEGER array of dimension (NMAT)
2597* Values of N to be tested.
2598*
2599* LDAS0 (input) INTEGER array of dimension (NMAT)
2600* Values of LDAS (leading dimension of A on source process)
2601* to be tested.
2602*
2603* LDAD0 (input) INTEGER array of dimension (NMAT)
2604* Values of LDAD (leading dimension of A on destination
2605* process) to be tested.
2606* NSRC (input) INTEGER
2607* The number of sources to be tested.
2608*
2609* RSRC0 (input) INTEGER array of dimension (NDEST)
2610* Values of RSRC (row coordinate of source) to be tested.
2611*
2612* CSRC0 (input) INTEGER array of dimension (NDEST)
2613* Values of CSRC (column coordinate of source) to be tested.
2614*
2615* RDEST0 (input) INTEGER array of dimension (NNSRC)
2616* Values of RDEST (row coordinate of destination) to be
2617* tested.
2618*
2619* CDEST0 (input) INTEGER array of dimension (NNSRC)
2620* Values of CDEST (column coordinate of destination) to be
2621* tested.
2622*
2623* NGRID (input) INTEGER
2624* The number of process grids to be tested.
2625*
2626* CONTEXT0 (input) INTEGER array of dimension (NGRID)
2627* The BLACS context handles corresponding to the grids.
2628*
2629* P0 (input) INTEGER array of dimension (NGRID)
2630* Values of P (number of process rows, NPROW).
2631*
2632* Q0 (input) INTEGER array of dimension (NGRID)
2633* Values of Q (number of process columns, NPCOL).
2634*
2635* TFAIL (workspace) INTEGER array of dimension (NTESTS)
2636* If VERB < 2, serves to indicate which tests fail. This
2637* requires workspace of NTESTS (number of tests performed).
2638*
2639* MEM (workspace) REAL array of dimension (MEMLEN)
2640* Used for all other workspaces, including the matrix A,
2641* and its pre and post padding.
2642*
2643* MEMLEN (input) INTEGER
2644* The length, in elements, of MEM.
2645*
2646* =====================================================================
2647*
2648* .. External Functions ..
2649 LOGICAL ALLPASS
2650 INTEGER IBTMYPROC, IBTSIZEOF
2651 EXTERNAL allpass, ibtmyproc, ibtsizeof
2652* ..
2653* .. External Subroutines ..
2654 EXTERNAL blacs_gridinfo
2655 EXTERNAL strsd2d, sgesd2d, strrv2d, sgerv2d
2656 EXTERNAL sinitmat, schkmat, schkpad, sbtcheckin
2657* ..
2658* .. Local Scalars ..
2659 CHARACTER*1 UPLO, DIAG
2660 LOGICAL TESTOK
2661 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
2662 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
2663 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
2664 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
2665 REAL SCHECKVAL, RCHECKVAL
2666* ..
2667* .. Executable Statements ..
2668*
2669 scheckval = -0.01e0
2670 rcheckval = -0.02e0
2671*
2672 iam = ibtmyproc()
2673 isize = ibtsizeof('I')
2674 ssize = ibtsizeof('S')
2675*
2676* Verify file parameters
2677*
2678 IF( iam .EQ. 0 ) THEN
2679 WRITE(outnum, *) ' '
2680 WRITE(outnum, *) ' '
2681 WRITE(outnum, 1000 )
2682 IF( verb .GT. 0 ) THEN
2683 WRITE(outnum,*) ' '
2684 WRITE(outnum, 2000) 'NSHAPE:', nshape
2685 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
2686 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
2687 WRITE(outnum, 2000) 'NMAT :', nmat
2688 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
2689 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
2690 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
2691 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
2692 WRITE(outnum, 2000) 'NSRC :', nsrc
2693 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
2694 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
2695 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
2696 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
2697 WRITE(outnum, 2000) 'NGRIDS:', ngrid
2698 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
2699 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
2700 WRITE(outnum, 2000) 'VERB :', verb
2701 WRITE(outnum,*) ' '
2702 END IF
2703 IF( verb .GT. 1 ) THEN
2704 WRITE(outnum,5000)
2705 WRITE(outnum,6000)
2706 END IF
2707 END IF
2708*
2709* Find biggest matrix, so we know where to stick error info
2710*
2711 i = 0
2712 DO 10 ima = 1, nmat
2713 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2714 IF( k .GT. i ) i = k
2715 10 CONTINUE
2716 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
2717 IF( maxerr .LT. 1 ) THEN
2718 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
2719 CALL blacs_abort(-1, 1)
2720 END IF
2721 errdptr = i + 1
2722 erriptr = errdptr + maxerr
2723 nerr = 0
2724 testnum = 0
2725 nfail = 0
2726 nskip = 0
2727*
2728* Loop over grids of matrix
2729*
2730 DO 110 igr = 1, ngrid
2731*
2732 context = context0(igr)
2733 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2734*
2735 DO 80 ish = 1, nshape
2736 uplo = uplo0(ish)
2737 diag = diag0(ish)
2738*
2739 DO 70 ima = 1, nmat
2740 m = m0(ima)
2741 n = n0(ima)
2742 ldasrc = ldas0(ima)
2743 ldadst = ldad0(ima)
2744*
2745 DO 60 iso = 1, nsrc
2746 testnum = testnum + 1
2747 rsrc = rsrc0(iso)
2748 csrc = csrc0(iso)
2749 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
2750 nskip = nskip + 1
2751 GOTO 60
2752 END IF
2753 rdest = rdest0(iso)
2754 cdest = cdest0(iso)
2755 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
2756 nskip = nskip + 1
2757 GOTO 60
2758 END IF
2759*
2760 IF( verb .GT. 1 ) THEN
2761 IF( iam .EQ. 0 ) THEN
2762 WRITE(outnum, 7000) testnum, 'RUNNING',
2763 $ uplo, diag, m, n,
2764 $ ldasrc, ldadst, rsrc, csrc,
2765 $ rdest, cdest, nprow, npcol
2766 END IF
2767 END IF
2768*
2769 testok = .true.
2770 ipre = 2 * m
2771 ipost = ipre
2772 aptr = ipre + 1
2773*
2774* source process generates matrix and sends it
2775*
2776 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
2777 CALL sinitmat( uplo, diag, m, n, mem, ldasrc,
2778 $ ipre, ipost, scheckval, testnum,
2779 $ myrow, mycol )
2780*
2781 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2782 CALL strsd2d( context, uplo, diag, m, n,
2783 $ mem(aptr), ldasrc, rdest, cdest )
2784 ELSE
2785 CALL sgesd2d( context, m, n, mem(aptr),
2786 $ ldasrc, rdest, cdest )
2787 END IF
2788 END IF
2789*
2790 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
2791*
2792* Pad entire matrix area
2793*
2794 DO 50 k = 1, ipre+ipost+ldadst*n
2795 mem(k) = rcheckval
2796 50 CONTINUE
2797*
2798* Receive matrix
2799*
2800 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2801 CALL strrv2d( context, uplo, diag, m, n,
2802 $ mem(aptr), ldadst, rsrc, csrc )
2803 ELSE
2804 CALL sgerv2d( context, m, n, mem(aptr),
2805 $ ldadst, rsrc, csrc )
2806 END IF
2807*
2808* Check for errors in matrix or padding
2809*
2810 i = nerr
2811 CALL schkmat( uplo, diag, m, n, mem(aptr), ldadst,
2812 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2813 $ nerr, mem(erriptr), mem(errdptr) )
2814*
2815 CALL schkpad( uplo, diag, m, n, mem, ldadst,
2816 $ rsrc, csrc, myrow, mycol, ipre, ipost,
2817 $ rcheckval, testnum, maxerr, nerr,
2818 $ mem(erriptr), mem(errdptr) )
2819 testok = i .EQ. nerr
2820 END IF
2821*
2822 IF( verb .GT. 1 ) THEN
2823 i = nerr
2824 CALL sbtcheckin( 0, outnum, maxerr, nerr,
2825 $ mem(erriptr), mem(errdptr),
2826 $ tfail )
2827 IF( iam .EQ. 0 ) THEN
2828 IF( testok .AND. i.EQ.nerr ) THEN
2829 WRITE(outnum, 7000) testnum, 'PASSED ',
2830 $ uplo, diag, m, n, ldasrc, ldadst,
2831 $ rsrc, csrc, rdest, cdest, nprow, npcol
2832 ELSE
2833 nfail = nfail + 1
2834 WRITE(outnum, 7000) testnum, 'FAILED ',
2835 $ uplo, diag, m, n, ldasrc, ldadst,
2836 $ rsrc, csrc, rdest, cdest, nprow, npcol
2837 ENDIF
2838 END IF
2839*
2840* Once we've printed out errors, can re-use buf space
2841*
2842 nerr = 0
2843 END IF
2844 60 CONTINUE
2845 70 CONTINUE
2846 80 CONTINUE
2847 110 CONTINUE
2848*
2849 IF( verb .LT. 2 ) THEN
2850 nfail = testnum
2851 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2852 $ mem(errdptr), tfail )
2853 END IF
2854 IF( iam .EQ. 0 ) THEN
2855 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
2856 IF( nfail+nskip .EQ. 0 ) THEN
2857 WRITE(outnum, 8000 ) testnum
2858 ELSE
2859 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2860 $ nskip, nfail
2861 END IF
2862 END IF
2863*
2864* Log whether their were any failures
2865*
2866 testok = allpass( (nfail.EQ.0) )
2867*
2868 1000 FORMAT('REAL SDRV TESTS: BEGIN.' )
2869 2000 FORMAT(1x,a7,3x,10i6)
2870 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
2871 $ 5x,a1,5x,a1)
2872 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
2873 $ 'CSRC RDEST CDEST P Q')
2874 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
2875 $ '---- ----- ----- ---- ----')
2876 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
2877 8000 FORMAT('REAL SDRV TESTS: PASSED ALL',
2878 $ i5, ' TESTS.')
2879 9000 FORMAT('REAL SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
2880 $ i5,' SKIPPED,',i5,' FAILED.')
2881*
2882 RETURN
2883*
2884* End of SSDRVTEST.
2885*
sbtcheckin
subroutine sbtcheckin(nftests, outnum, maxerr, nerr, ierr, sval, tfailed)
Definition blacstest.f:7341
schkpad
subroutine schkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:7746
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
sinitmat
subroutine sinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:7463
schkmat
subroutine schkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:8007
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
ibtsizeof
integer function ibtsizeof(type)
Definition btprim.f:286
Here is the caller graph for this function: