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

◆ zsdrvtest()

subroutine zsdrvtest ( 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,
double complex, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 3577 of file blacstest.f.

3581*
3582* -- BLACS tester (version 1.0) --
3583* University of Tennessee
3584* December 15, 1994
3585*
3586*
3587* .. Scalar Arguments ..
3588 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
3589* ..
3590* .. Array Arguments ..
3591 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3592 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3593 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
3594 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
3595 DOUBLE COMPLEX MEM(MEMLEN)
3596* ..
3597*
3598* Purpose
3599* =======
3600* ZTESTSDRV: Test double complex send/recv
3601*
3602* Arguments
3603* =========
3604* OUTNUM (input) INTEGER
3605* The device number to write output to.
3606*
3607* VERB (input) INTEGER
3608* The level of verbosity (how much printing to do).
3609*
3610* NSHAPE (input) INTEGER
3611* The number of matrix shapes to be tested.
3612*
3613* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3614* Values of UPLO to be tested.
3615*
3616* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3617* Values of DIAG to be tested.
3618*
3619* NMAT (input) INTEGER
3620* The number of matrices to be tested.
3621*
3622* M0 (input) INTEGER array of dimension (NMAT)
3623* Values of M to be tested.
3624*
3625* M0 (input) INTEGER array of dimension (NMAT)
3626* Values of M to be tested.
3627*
3628* N0 (input) INTEGER array of dimension (NMAT)
3629* Values of N to be tested.
3630*
3631* LDAS0 (input) INTEGER array of dimension (NMAT)
3632* Values of LDAS (leading dimension of A on source process)
3633* to be tested.
3634*
3635* LDAD0 (input) INTEGER array of dimension (NMAT)
3636* Values of LDAD (leading dimension of A on destination
3637* process) to be tested.
3638* NSRC (input) INTEGER
3639* The number of sources to be tested.
3640*
3641* RSRC0 (input) INTEGER array of dimension (NDEST)
3642* Values of RSRC (row coordinate of source) to be tested.
3643*
3644* CSRC0 (input) INTEGER array of dimension (NDEST)
3645* Values of CSRC (column coordinate of source) to be tested.
3646*
3647* RDEST0 (input) INTEGER array of dimension (NNSRC)
3648* Values of RDEST (row coordinate of destination) to be
3649* tested.
3650*
3651* CDEST0 (input) INTEGER array of dimension (NNSRC)
3652* Values of CDEST (column coordinate of destination) to be
3653* tested.
3654*
3655* NGRID (input) INTEGER
3656* The number of process grids to be tested.
3657*
3658* CONTEXT0 (input) INTEGER array of dimension (NGRID)
3659* The BLACS context handles corresponding to the grids.
3660*
3661* P0 (input) INTEGER array of dimension (NGRID)
3662* Values of P (number of process rows, NPROW).
3663*
3664* Q0 (input) INTEGER array of dimension (NGRID)
3665* Values of Q (number of process columns, NPCOL).
3666*
3667* TFAIL (workspace) INTEGER array of dimension (NTESTS)
3668* If VERB < 2, serves to indicate which tests fail. This
3669* requires workspace of NTESTS (number of tests performed).
3670*
3671* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
3672* Used for all other workspaces, including the matrix A,
3673* and its pre and post padding.
3674*
3675* MEMLEN (input) INTEGER
3676* The length, in elements, of MEM.
3677*
3678* =====================================================================
3679*
3680* .. External Functions ..
3681 LOGICAL ALLPASS
3682 INTEGER IBTMYPROC, IBTSIZEOF
3683 EXTERNAL allpass, ibtmyproc, ibtsizeof
3684* ..
3685* .. External Subroutines ..
3686 EXTERNAL blacs_gridinfo
3687 EXTERNAL ztrsd2d, zgesd2d, ztrrv2d, zgerv2d
3688 EXTERNAL zinitmat, zchkmat, zchkpad, zbtcheckin
3689* ..
3690* .. Local Scalars ..
3691 CHARACTER*1 UPLO, DIAG
3692 LOGICAL TESTOK
3693 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3694 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3695 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3696 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
3697 DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
3698* ..
3699* .. Executable Statements ..
3700*
3701 scheckval = dcmplx( -0.01d0, -0.01d0 )
3702 rcheckval = dcmplx( -0.02d0, -0.02d0 )
3703*
3704 iam = ibtmyproc()
3705 isize = ibtsizeof('I')
3706 zsize = ibtsizeof('Z')
3707*
3708* Verify file parameters
3709*
3710 IF( iam .EQ. 0 ) THEN
3711 WRITE(outnum, *) ' '
3712 WRITE(outnum, *) ' '
3713 WRITE(outnum, 1000 )
3714 IF( verb .GT. 0 ) THEN
3715 WRITE(outnum,*) ' '
3716 WRITE(outnum, 2000) 'NSHAPE:', nshape
3717 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3718 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3719 WRITE(outnum, 2000) 'NMAT :', nmat
3720 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3721 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3722 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3723 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3724 WRITE(outnum, 2000) 'NSRC :', nsrc
3725 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3726 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3727 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3728 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3729 WRITE(outnum, 2000) 'NGRIDS:', ngrid
3730 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3731 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3732 WRITE(outnum, 2000) 'VERB :', verb
3733 WRITE(outnum,*) ' '
3734 END IF
3735 IF( verb .GT. 1 ) THEN
3736 WRITE(outnum,5000)
3737 WRITE(outnum,6000)
3738 END IF
3739 END IF
3740*
3741* Find biggest matrix, so we know where to stick error info
3742*
3743 i = 0
3744 DO 10 ima = 1, nmat
3745 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3746 IF( k .GT. i ) i = k
3747 10 CONTINUE
3748 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
3749 IF( maxerr .LT. 1 ) THEN
3750 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3751 CALL blacs_abort(-1, 1)
3752 END IF
3753 errdptr = i + 1
3754 erriptr = errdptr + maxerr
3755 nerr = 0
3756 testnum = 0
3757 nfail = 0
3758 nskip = 0
3759*
3760* Loop over grids of matrix
3761*
3762 DO 110 igr = 1, ngrid
3763*
3764 context = context0(igr)
3765 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3766*
3767 DO 80 ish = 1, nshape
3768 uplo = uplo0(ish)
3769 diag = diag0(ish)
3770*
3771 DO 70 ima = 1, nmat
3772 m = m0(ima)
3773 n = n0(ima)
3774 ldasrc = ldas0(ima)
3775 ldadst = ldad0(ima)
3776*
3777 DO 60 iso = 1, nsrc
3778 testnum = testnum + 1
3779 rsrc = rsrc0(iso)
3780 csrc = csrc0(iso)
3781 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3782 nskip = nskip + 1
3783 GOTO 60
3784 END IF
3785 rdest = rdest0(iso)
3786 cdest = cdest0(iso)
3787 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3788 nskip = nskip + 1
3789 GOTO 60
3790 END IF
3791*
3792 IF( verb .GT. 1 ) THEN
3793 IF( iam .EQ. 0 ) THEN
3794 WRITE(outnum, 7000) testnum, 'RUNNING',
3795 $ uplo, diag, m, n,
3796 $ ldasrc, ldadst, rsrc, csrc,
3797 $ rdest, cdest, nprow, npcol
3798 END IF
3799 END IF
3800*
3801 testok = .true.
3802 ipre = 2 * m
3803 ipost = ipre
3804 aptr = ipre + 1
3805*
3806* source process generates matrix and sends it
3807*
3808 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3809 CALL zinitmat( uplo, diag, m, n, mem, ldasrc,
3810 $ ipre, ipost, scheckval, testnum,
3811 $ myrow, mycol )
3812*
3813 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3814 CALL ztrsd2d( context, uplo, diag, m, n,
3815 $ mem(aptr), ldasrc, rdest, cdest )
3816 ELSE
3817 CALL zgesd2d( context, m, n, mem(aptr),
3818 $ ldasrc, rdest, cdest )
3819 END IF
3820 END IF
3821*
3822 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3823*
3824* Pad entire matrix area
3825*
3826 DO 50 k = 1, ipre+ipost+ldadst*n
3827 mem(k) = rcheckval
3828 50 CONTINUE
3829*
3830* Receive matrix
3831*
3832 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3833 CALL ztrrv2d( context, uplo, diag, m, n,
3834 $ mem(aptr), ldadst, rsrc, csrc )
3835 ELSE
3836 CALL zgerv2d( context, m, n, mem(aptr),
3837 $ ldadst, rsrc, csrc )
3838 END IF
3839*
3840* Check for errors in matrix or padding
3841*
3842 i = nerr
3843 CALL zchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3844 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3845 $ nerr, mem(erriptr), mem(errdptr) )
3846*
3847 CALL zchkpad( uplo, diag, m, n, mem, ldadst,
3848 $ rsrc, csrc, myrow, mycol, ipre, ipost,
3849 $ rcheckval, testnum, maxerr, nerr,
3850 $ mem(erriptr), mem(errdptr) )
3851 testok = i .EQ. nerr
3852 END IF
3853*
3854 IF( verb .GT. 1 ) THEN
3855 i = nerr
3856 CALL zbtcheckin( 0, outnum, maxerr, nerr,
3857 $ mem(erriptr), mem(errdptr),
3858 $ tfail )
3859 IF( iam .EQ. 0 ) THEN
3860 IF( testok .AND. i.EQ.nerr ) THEN
3861 WRITE(outnum, 7000) testnum, 'PASSED ',
3862 $ uplo, diag, m, n, ldasrc, ldadst,
3863 $ rsrc, csrc, rdest, cdest, nprow, npcol
3864 ELSE
3865 nfail = nfail + 1
3866 WRITE(outnum, 7000) testnum, 'FAILED ',
3867 $ uplo, diag, m, n, ldasrc, ldadst,
3868 $ rsrc, csrc, rdest, cdest, nprow, npcol
3869 ENDIF
3870 END IF
3871*
3872* Once we've printed out errors, can re-use buf space
3873*
3874 nerr = 0
3875 END IF
3876 60 CONTINUE
3877 70 CONTINUE
3878 80 CONTINUE
3879 110 CONTINUE
3880*
3881 IF( verb .LT. 2 ) THEN
3882 nfail = testnum
3883 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3884 $ mem(errdptr), tfail )
3885 END IF
3886 IF( iam .EQ. 0 ) THEN
3887 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3888 IF( nfail+nskip .EQ. 0 ) THEN
3889 WRITE(outnum, 8000 ) testnum
3890 ELSE
3891 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3892 $ nskip, nfail
3893 END IF
3894 END IF
3895*
3896* Log whether their were any failures
3897*
3898 testok = allpass( (nfail.EQ.0) )
3899*
3900 1000 FORMAT('DOUBLE COMPLEX SDRV TESTS: BEGIN.' )
3901 2000 FORMAT(1x,a7,3x,10i6)
3902 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3903 $ 5x,a1,5x,a1)
3904 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3905 $ 'CSRC RDEST CDEST P Q')
3906 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3907 $ '---- ----- ----- ---- ----')
3908 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3909 8000 FORMAT('DOUBLE COMPLEX SDRV TESTS: PASSED ALL',
3910 $ i5, ' TESTS.')
3911 9000 FORMAT('DOUBLE COMPLEX SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3912 $ i5,' SKIPPED,',i5,' FAILED.')
3913*
3914 RETURN
3915*
3916* End of ZSDRVTEST.
3917*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
zchkmat
subroutine zchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:11201
zinitmat
subroutine zinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:10659
zchkpad
subroutine zchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:10940
zbtcheckin
subroutine zbtcheckin(nftests, outnum, maxerr, nerr, ierr, zval, tfailed)
Definition blacstest.f:10537
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: