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

◆ iamntest()

subroutine iamntest ( integer  outnum,
integer  verb,
integer  topsrepeat,
integer  topscohrnt,
integer  nscope,
character*1, dimension(nscope)  scope0,
integer  ntop,
character*1, dimension(ntop)  top0,
integer  nmat,
integer, dimension(nmat)  m0,
integer, dimension(nmat)  n0,
integer, dimension(nmat)  ldas0,
integer, dimension(nmat)  ldad0,
integer, dimension(nmat)  ldi0,
integer  ndest,
integer, dimension(ndest)  rdest0,
integer, dimension(ndest)  cdest0,
integer  ngrid,
integer, dimension(ngrid)  context0,
integer, dimension(ngrid)  p0,
integer, dimension(ngrid)  q0,
integer, dimension(*)  iseed,
integer, dimension(rclen)  rmem,
integer, dimension(rclen)  cmem,
integer  rclen,
integer, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 18494 of file blacstest.f.

18499*
18500* -- BLACS tester (version 1.0) --
18501* University of Tennessee
18502* December 15, 1994
18503*
18504*
18505* .. Scalar Arguments ..
18506 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
18507 $ TOPSCOHRNT, TOPSREPEAT, VERB
18508* ..
18509* .. Array Arguments ..
18510 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
18511 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
18512 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
18513 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
18514 INTEGER MEM(MEMLEN)
18515* ..
18516*
18517* Purpose
18518* =======
18519* ITESTAMN: Test integer AMN COMBINE
18520*
18521* Arguments
18522* =========
18523* OUTNUM (input) INTEGER
18524* The device number to write output to.
18525*
18526* VERB (input) INTEGER
18527* The level of verbosity (how much printing to do).
18528*
18529* NSCOPE (input) INTEGER
18530* The number of scopes to be tested.
18531*
18532* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
18533* Values of the scopes to be tested.
18534*
18535* NTOP (input) INTEGER
18536* The number of topologies to be tested.
18537*
18538* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
18539* Values of the topologies to be tested.
18540*
18541* NMAT (input) INTEGER
18542* The number of matrices to be tested.
18543*
18544* M0 (input) INTEGER array of dimension (NMAT)
18545* Values of M to be tested.
18546*
18547* M0 (input) INTEGER array of dimension (NMAT)
18548* Values of M to be tested.
18549*
18550* N0 (input) INTEGER array of dimension (NMAT)
18551* Values of N to be tested.
18552*
18553* LDAS0 (input) INTEGER array of dimension (NMAT)
18554* Values of LDAS (leading dimension of A on source process)
18555* to be tested.
18556*
18557* LDAD0 (input) INTEGER array of dimension (NMAT)
18558* Values of LDAD (leading dimension of A on destination
18559* process) to be tested.
18560* LDI0 (input) INTEGER array of dimension (NMAT)
18561* Values of LDI (leading dimension of RA/CA) to be tested.
18562* If LDI == -1, these RA/CA should not be accessed.
18563*
18564* NDEST (input) INTEGER
18565* The number of destinations to be tested.
18566*
18567* RDEST0 (input) INTEGER array of dimension (NNDEST)
18568* Values of RDEST (row coordinate of destination) to be
18569* tested.
18570*
18571* CDEST0 (input) INTEGER array of dimension (NNDEST)
18572* Values of CDEST (column coordinate of destination) to be
18573* tested.
18574*
18575* NGRID (input) INTEGER
18576* The number of process grids to be tested.
18577*
18578* CONTEXT0 (input) INTEGER array of dimension (NGRID)
18579* The BLACS context handles corresponding to the grids.
18580*
18581* P0 (input) INTEGER array of dimension (NGRID)
18582* Values of P (number of process rows, NPROW).
18583*
18584* Q0 (input) INTEGER array of dimension (NGRID)
18585* Values of Q (number of process columns, NPCOL).
18586*
18587* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
18588* Workspace used to hold each process's random number SEED.
18589* This requires NPROCS (number of processor) elements.
18590* If VERB < 2, this workspace also serves to indicate which
18591* tests fail. This requires workspace of NTESTS
18592* (number of tests performed).
18593*
18594* RMEM (workspace) INTEGER array of dimension (RCLEN)
18595* Used for all RA arrays, and their pre and post padding.
18596*
18597* CMEM (workspace) INTEGER array of dimension (RCLEN)
18598* Used for all CA arrays, and their pre and post padding.
18599*
18600* RCLEN (input) INTEGER
18601* The length, in elements, of RMEM and CMEM.
18602*
18603* MEM (workspace) INTEGER array of dimension (MEMLEN)
18604* Used for all other workspaces, including the matrix A,
18605* and its pre and post padding.
18606*
18607* MEMLEN (input) INTEGER
18608* The length, in elements, of MEM.
18609*
18610* =====================================================================
18611*
18612* .. External Functions ..
18613 LOGICAL ALLPASS, LSAME
18614 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
18615 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
18616* ..
18617* .. External Subroutines ..
18618 EXTERNAL blacs_gridinfo, igamn2d
18619 EXTERNAL iinitmat, ichkpad, ibtcheckin
18620* ..
18621* .. Local Scalars ..
18622 CHARACTER*1 SCOPE, TOP
18623 LOGICAL INGRID, TESTOK, ALLRCV
18624 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
18625 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
18626 $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
18627 $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
18628 $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
18629 $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
18630 INTEGER CHECKVAL
18631* ..
18632* .. Executable Statements ..
18633*
18634* Choose padding value, and make it unique
18635*
18636 checkval = -911
18637 iam = ibtmyproc()
18638 checkval = iam * checkval
18639 isize = ibtsizeof('I')
18640 icheckval = -iam
18641*
18642* Verify file parameters
18643*
18644 IF( iam .EQ. 0 ) THEN
18645 WRITE(outnum, *) ' '
18646 WRITE(outnum, *) ' '
18647 WRITE(outnum, 1000 )
18648 IF( verb .GT. 0 ) THEN
18649 WRITE(outnum,*) ' '
18650 WRITE(outnum, 2000) 'NSCOPE:', nscope
18651 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
18652 WRITE(outnum, 2000) 'TReps :', topsrepeat
18653 WRITE(outnum, 2000) 'TCohr :', topscohrnt
18654 WRITE(outnum, 2000) 'NTOP :', ntop
18655 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
18656 WRITE(outnum, 2000) 'NMAT :', nmat
18657 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
18658 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
18659 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
18660 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
18661 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
18662 WRITE(outnum, 2000) 'NDEST :', ndest
18663 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
18664 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
18665 WRITE(outnum, 2000) 'NGRIDS:', ngrid
18666 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
18667 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
18668 WRITE(outnum, 2000) 'VERB :', verb
18669 WRITE(outnum,*) ' '
18670 END IF
18671 IF( verb .GT. 1 ) THEN
18672 WRITE(outnum,4000)
18673 WRITE(outnum,5000)
18674 END IF
18675 END IF
18676 IF (topsrepeat.EQ.0) THEN
18677 itr1 = 0
18678 itr2 = 0
18679 ELSE IF (topsrepeat.EQ.1) THEN
18680 itr1 = 1
18681 itr2 = 1
18682 ELSE
18683 itr1 = 0
18684 itr2 = 1
18685 END IF
18686*
18687* Find biggest matrix, so we know where to stick error info
18688*
18689 i = 0
18690 DO 10 ima = 1, nmat
18691 ipad = 4 * m0(ima)
18692 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
18693 IF( k .GT. i ) i = k
18694 10 CONTINUE
18695 i = i + ibtnprocs()
18696 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
18697 IF( maxerr .LT. 1 ) THEN
18698 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
18699 CALL blacs_abort(-1, 1)
18700 END IF
18701 errdptr = i + 1
18702 erriptr = errdptr + maxerr
18703 nerr = 0
18704 testnum = 0
18705 nfail = 0
18706 nskip = 0
18707*
18708* Loop over grids of matrix
18709*
18710 DO 90 igr = 1, ngrid
18711*
18712* allocate process grid for the next batch of tests
18713*
18714 context = context0(igr)
18715 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
18716 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
18717*
18718 DO 80 isc = 1, nscope
18719 scope = scope0(isc)
18720 DO 70 ito = 1, ntop
18721 top = top0(ito)
18722*
18723* If testing multiring ('M') or general tree ('T'), need to
18724* loop over calls to BLACS_SET to do full test
18725*
18726 IF( lsame(top, 'M') ) THEN
18727 setwhat = 13
18728 IF( scope .EQ. 'R' ) THEN
18729 istart = -(npcol - 1)
18730 istop = -istart
18731 ELSE IF (scope .EQ. 'C') THEN
18732 istart = -(nprow - 1)
18733 istop = -istart
18734 ELSE
18735 istart = -(nprow*npcol - 1)
18736 istop = -istart
18737 ENDIF
18738 ELSE IF( lsame(top, 'T') ) THEN
18739 setwhat = 14
18740 istart = 1
18741 IF( scope .EQ. 'R' ) THEN
18742 istop = npcol - 1
18743 ELSE IF (scope .EQ. 'C') THEN
18744 istop = nprow - 1
18745 ELSE
18746 istop = nprow*npcol - 1
18747 ENDIF
18748 ELSE
18749 setwhat = 0
18750 istart = 1
18751 istop = 1
18752 ENDIF
18753 DO 60 ima = 1, nmat
18754 m = m0(ima)
18755 n = n0(ima)
18756 ldasrc = ldas0(ima)
18757 ldadst = ldad0(ima)
18758 ldi = ldi0(ima)
18759 ipre = 2 * m
18760 ipost = ipre
18761 preaptr = 1
18762 aptr = preaptr + ipre
18763*
18764 DO 50 ide = 1, ndest
18765 testnum = testnum + 1
18766 rdest2 = rdest0(ide)
18767 cdest2 = cdest0(ide)
18768*
18769* If everyone gets the answer, create some bogus rdest/cdest
18770* so IF's are easier
18771*
18772 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
18773 IF( allrcv ) THEN
18774 rdest = nprow - 1
18775 cdest = npcol - 1
18776 IF (topscohrnt.EQ.0) THEN
18777 itr1 = 0
18778 itr2 = 0
18779 ELSE IF (topscohrnt.EQ.1) THEN
18780 itr1 = 1
18781 itr2 = 1
18782 ELSE
18783 itr1 = 0
18784 itr2 = 1
18785 END IF
18786 ELSE
18787 rdest = rdest2
18788 cdest = cdest2
18789 itc1 = 0
18790 itc2 = 0
18791 END IF
18792 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
18793 nskip = nskip + 1
18794 GOTO 50
18795 END IF
18796*
18797 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
18798 lda = ldadst
18799 ELSE
18800 lda = ldasrc
18801 END IF
18802 valptr = aptr + ipost + n * lda
18803 IF( verb .GT. 1 ) THEN
18804 IF( iam .EQ. 0 ) THEN
18805 WRITE(outnum, 6000)
18806 $ testnum, 'RUNNING', scope, top, m, n,
18807 $ ldasrc, ldadst, ldi, rdest2, cdest2,
18808 $ nprow, npcol
18809 END IF
18810 END IF
18811*
18812* If I am in scope
18813*
18814 testok = .true.
18815 IF( ingrid ) THEN
18816 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
18817 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
18818 $ (scope .EQ. 'A') ) THEN
18819*
18820 k = nerr
18821 DO 40 itr = itr1, itr2
18822 CALL blacs_set(context, 15, itr)
18823 DO 35 itc = itc1, itc2
18824 CALL blacs_set(context, 16, itc)
18825 DO 30 j = istart, istop
18826 IF( j.EQ.0) GOTO 30
18827 IF( setwhat.NE.0 )
18828 $ CALL blacs_set(context, setwhat, j)
18829*
18830*
18831* generate and pad matrix A
18832*
18833 CALL iinitmat('G','-', m, n, mem(preaptr),
18834 $ lda, ipre, ipost,
18835 $ checkval, testnum,
18836 $ myrow, mycol )
18837*
18838* If they exist, pad RA and CA arrays
18839*
18840 IF( ldi .NE. -1 ) THEN
18841 DO 15 i = 1, n*ldi + ipre + ipost
18842 rmem(i) = icheckval
18843 cmem(i) = icheckval
18844 15 CONTINUE
18845 raptr = 1 + ipre
18846 captr = 1 + ipre
18847 ELSE
18848 DO 20 i = 1, ipre+ipost
18849 rmem(i) = icheckval
18850 cmem(i) = icheckval
18851 20 CONTINUE
18852 raptr = 1
18853 captr = 1
18854 END IF
18855*
18856 CALL igamn2d(context, scope, top, m, n,
18857 $ mem(aptr), lda, rmem(raptr),
18858 $ cmem(captr), ldi,
18859 $ rdest2, cdest2)
18860*
18861* If I've got the answer, check for errors in
18862* matrix or padding
18863*
18864 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
18865 $ .OR. allrcv ) THEN
18866 CALL ichkpad('G','-', m, n,
18867 $ mem(preaptr), lda, rdest,
18868 $ cdest, myrow, mycol,
18869 $ ipre, ipost, checkval,
18870 $ testnum, maxerr, nerr,
18871 $ mem(erriptr),mem(errdptr))
18872 CALL ichkamn(scope, context, m, n,
18873 $ mem(aptr), lda,
18874 $ rmem(raptr), cmem(captr),
18875 $ ldi, testnum, maxerr,nerr,
18876 $ mem(erriptr),mem(errdptr),
18877 $ iseed, mem(valptr))
18878 CALL ircchk(ipre, ipost, icheckval,
18879 $ m, n, rmem, cmem, ldi,
18880 $ myrow, mycol, testnum,
18881 $ maxerr, nerr,
18882 $ mem(erriptr), mem(errdptr))
18883 END IF
18884 30 CONTINUE
18885 CALL blacs_set(context, 16, 0)
18886 35 CONTINUE
18887 CALL blacs_set(context, 15, 0)
18888 40 CONTINUE
18889 testok = ( k .EQ. nerr )
18890 END IF
18891 END IF
18892*
18893 IF( verb .GT. 1 ) THEN
18894 i = nerr
18895 CALL ibtcheckin(0, outnum, maxerr, nerr,
18896 $ mem(erriptr), mem(errdptr), iseed)
18897 IF( iam .EQ. 0 ) THEN
18898 IF( testok .AND. nerr.EQ.i ) THEN
18899 WRITE(outnum,6000)testnum,'PASSED ',
18900 $ scope, top, m, n, ldasrc,
18901 $ ldadst, ldi, rdest2, cdest2,
18902 $ nprow, npcol
18903 ELSE
18904 nfail = nfail + 1
18905 WRITE(outnum,6000)testnum,'FAILED ',
18906 $ scope, top, m, n, ldasrc,
18907 $ ldadst, ldi, rdest2, cdest2,
18908 $ nprow, npcol
18909 END IF
18910 END IF
18911*
18912* Once we've printed out errors, can re-use buf space
18913*
18914 nerr = 0
18915 END IF
18916 50 CONTINUE
18917 60 CONTINUE
18918 70 CONTINUE
18919 80 CONTINUE
18920 90 CONTINUE
18921*
18922 IF( verb .LT. 2 ) THEN
18923 nfail = testnum
18924 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
18925 $ mem(errdptr), iseed )
18926 END IF
18927 IF( iam .EQ. 0 ) THEN
18928 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
18929 IF( nfail+nskip .EQ. 0 ) THEN
18930 WRITE(outnum, 7000 ) testnum
18931 ELSE
18932 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
18933 $ nskip, nfail
18934 END IF
18935 END IF
18936*
18937* Log whether their were any failures
18938*
18939 testok = allpass( (nfail.EQ.0) )
18940*
18941 1000 FORMAT('INTEGER AMN TESTS: BEGIN.' )
18942 2000 FORMAT(1x,a7,3x,10i6)
18943 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
18944 $ 5x,a1,5x,a1)
18945 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
18946 $ 'RDEST CDEST P Q')
18947 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
18948 $ '----- ----- ---- ----')
18949 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
18950 7000 FORMAT('INTEGER AMN TESTS: PASSED ALL',
18951 $ i5, ' TESTS.')
18952 8000 FORMAT('INTEGER AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
18953 $ i5,' SKIPPED,',i5,' FAILED.')
18954*
18955 RETURN
18956*
18957* End of ITESTAMN.
18958*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
ircchk
subroutine ircchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:14889
iinitmat
subroutine iinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:6394
ichkamn
subroutine ichkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:18964
ibtcheckin
subroutine ibtcheckin(nftests, outnum, maxerr, nerr, ierr, ival, tfailed)
Definition blacstest.f:6272
ichkpad
subroutine ichkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:6682
ibtnprocs
integer function ibtnprocs()
Definition btprim.f:81
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
ibtsizeof
integer function ibtsizeof(type)
Definition btprim.f:286
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the call graph for this function:
Here is the caller graph for this function: