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

◆ camntest()

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

Definition at line 20428 of file blacstest.f.

20433*
20434* -- BLACS tester (version 1.0) --
20435* University of Tennessee
20436* December 15, 1994
20437*
20438*
20439* .. Scalar Arguments ..
20440 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
20441 $ TOPSCOHRNT, TOPSREPEAT, VERB
20442* ..
20443* .. Array Arguments ..
20444 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
20445 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
20446 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
20447 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
20448 COMPLEX MEM(MEMLEN)
20449* ..
20450*
20451* Purpose
20452* =======
20453* CTESTAMN: Test complex AMN COMBINE
20454*
20455* Arguments
20456* =========
20457* OUTNUM (input) INTEGER
20458* The device number to write output to.
20459*
20460* VERB (input) INTEGER
20461* The level of verbosity (how much printing to do).
20462*
20463* NSCOPE (input) INTEGER
20464* The number of scopes to be tested.
20465*
20466* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
20467* Values of the scopes to be tested.
20468*
20469* NTOP (input) INTEGER
20470* The number of topologies to be tested.
20471*
20472* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
20473* Values of the topologies to be tested.
20474*
20475* NMAT (input) INTEGER
20476* The number of matrices to be tested.
20477*
20478* M0 (input) INTEGER array of dimension (NMAT)
20479* Values of M to be tested.
20480*
20481* M0 (input) INTEGER array of dimension (NMAT)
20482* Values of M to be tested.
20483*
20484* N0 (input) INTEGER array of dimension (NMAT)
20485* Values of N to be tested.
20486*
20487* LDAS0 (input) INTEGER array of dimension (NMAT)
20488* Values of LDAS (leading dimension of A on source process)
20489* to be tested.
20490*
20491* LDAD0 (input) INTEGER array of dimension (NMAT)
20492* Values of LDAD (leading dimension of A on destination
20493* process) to be tested.
20494* LDI0 (input) INTEGER array of dimension (NMAT)
20495* Values of LDI (leading dimension of RA/CA) to be tested.
20496* If LDI == -1, these RA/CA should not be accessed.
20497*
20498* NDEST (input) INTEGER
20499* The number of destinations to be tested.
20500*
20501* RDEST0 (input) INTEGER array of dimension (NNDEST)
20502* Values of RDEST (row coordinate of destination) to be
20503* tested.
20504*
20505* CDEST0 (input) INTEGER array of dimension (NNDEST)
20506* Values of CDEST (column coordinate of destination) to be
20507* tested.
20508*
20509* NGRID (input) INTEGER
20510* The number of process grids to be tested.
20511*
20512* CONTEXT0 (input) INTEGER array of dimension (NGRID)
20513* The BLACS context handles corresponding to the grids.
20514*
20515* P0 (input) INTEGER array of dimension (NGRID)
20516* Values of P (number of process rows, NPROW).
20517*
20518* Q0 (input) INTEGER array of dimension (NGRID)
20519* Values of Q (number of process columns, NPCOL).
20520*
20521* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
20522* Workspace used to hold each process's random number SEED.
20523* This requires NPROCS (number of processor) elements.
20524* If VERB < 2, this workspace also serves to indicate which
20525* tests fail. This requires workspace of NTESTS
20526* (number of tests performed).
20527*
20528* RMEM (workspace) INTEGER array of dimension (RCLEN)
20529* Used for all RA arrays, and their pre and post padding.
20530*
20531* CMEM (workspace) INTEGER array of dimension (RCLEN)
20532* Used for all CA arrays, and their pre and post padding.
20533*
20534* RCLEN (input) INTEGER
20535* The length, in elements, of RMEM and CMEM.
20536*
20537* MEM (workspace) COMPLEX array of dimension (MEMLEN)
20538* Used for all other workspaces, including the matrix A,
20539* and its pre and post padding.
20540*
20541* MEMLEN (input) INTEGER
20542* The length, in elements, of MEM.
20543*
20544* =====================================================================
20545*
20546* .. External Functions ..
20547 LOGICAL ALLPASS, LSAME
20548 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
20549 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
20550* ..
20551* .. External Subroutines ..
20552 EXTERNAL blacs_gridinfo, cgamn2d
20553 EXTERNAL cinitmat, cchkpad, cbtcheckin
20554* ..
20555* .. Local Scalars ..
20556 CHARACTER*1 SCOPE, TOP
20557 LOGICAL INGRID, TESTOK, ALLRCV
20558 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
20559 $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
20560 $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
20561 $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
20562 $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
20563 $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
20564 COMPLEX CHECKVAL
20565* ..
20566* .. Executable Statements ..
20567*
20568* Choose padding value, and make it unique
20569*
20570 checkval = cmplx( -0.91e0, -0.71e0 )
20571 iam = ibtmyproc()
20572 checkval = iam * checkval
20573 isize = ibtsizeof('I')
20574 csize = ibtsizeof('C')
20575 icheckval = -iam
20576*
20577* Verify file parameters
20578*
20579 IF( iam .EQ. 0 ) THEN
20580 WRITE(outnum, *) ' '
20581 WRITE(outnum, *) ' '
20582 WRITE(outnum, 1000 )
20583 IF( verb .GT. 0 ) THEN
20584 WRITE(outnum,*) ' '
20585 WRITE(outnum, 2000) 'NSCOPE:', nscope
20586 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
20587 WRITE(outnum, 2000) 'TReps :', topsrepeat
20588 WRITE(outnum, 2000) 'TCohr :', topscohrnt
20589 WRITE(outnum, 2000) 'NTOP :', ntop
20590 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
20591 WRITE(outnum, 2000) 'NMAT :', nmat
20592 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
20593 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
20594 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
20595 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
20596 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
20597 WRITE(outnum, 2000) 'NDEST :', ndest
20598 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
20599 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
20600 WRITE(outnum, 2000) 'NGRIDS:', ngrid
20601 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
20602 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
20603 WRITE(outnum, 2000) 'VERB :', verb
20604 WRITE(outnum,*) ' '
20605 END IF
20606 IF( verb .GT. 1 ) THEN
20607 WRITE(outnum,4000)
20608 WRITE(outnum,5000)
20609 END IF
20610 END IF
20611 IF (topsrepeat.EQ.0) THEN
20612 itr1 = 0
20613 itr2 = 0
20614 ELSE IF (topsrepeat.EQ.1) THEN
20615 itr1 = 1
20616 itr2 = 1
20617 ELSE
20618 itr1 = 0
20619 itr2 = 1
20620 END IF
20621*
20622* Find biggest matrix, so we know where to stick error info
20623*
20624 i = 0
20625 DO 10 ima = 1, nmat
20626 ipad = 4 * m0(ima)
20627 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
20628 IF( k .GT. i ) i = k
20629 10 CONTINUE
20630 i = i + ibtnprocs()
20631 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
20632 IF( maxerr .LT. 1 ) THEN
20633 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
20634 CALL blacs_abort(-1, 1)
20635 END IF
20636 errdptr = i + 1
20637 erriptr = errdptr + maxerr
20638 nerr = 0
20639 testnum = 0
20640 nfail = 0
20641 nskip = 0
20642*
20643* Loop over grids of matrix
20644*
20645 DO 90 igr = 1, ngrid
20646*
20647* allocate process grid for the next batch of tests
20648*
20649 context = context0(igr)
20650 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
20651 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
20652*
20653 DO 80 isc = 1, nscope
20654 scope = scope0(isc)
20655 DO 70 ito = 1, ntop
20656 top = top0(ito)
20657*
20658* If testing multiring ('M') or general tree ('T'), need to
20659* loop over calls to BLACS_SET to do full test
20660*
20661 IF( lsame(top, 'M') ) THEN
20662 setwhat = 13
20663 IF( scope .EQ. 'R' ) THEN
20664 istart = -(npcol - 1)
20665 istop = -istart
20666 ELSE IF (scope .EQ. 'C') THEN
20667 istart = -(nprow - 1)
20668 istop = -istart
20669 ELSE
20670 istart = -(nprow*npcol - 1)
20671 istop = -istart
20672 ENDIF
20673 ELSE IF( lsame(top, 'T') ) THEN
20674 setwhat = 14
20675 istart = 1
20676 IF( scope .EQ. 'R' ) THEN
20677 istop = npcol - 1
20678 ELSE IF (scope .EQ. 'C') THEN
20679 istop = nprow - 1
20680 ELSE
20681 istop = nprow*npcol - 1
20682 ENDIF
20683 ELSE
20684 setwhat = 0
20685 istart = 1
20686 istop = 1
20687 ENDIF
20688 DO 60 ima = 1, nmat
20689 m = m0(ima)
20690 n = n0(ima)
20691 ldasrc = ldas0(ima)
20692 ldadst = ldad0(ima)
20693 ldi = ldi0(ima)
20694 ipre = 2 * m
20695 ipost = ipre
20696 preaptr = 1
20697 aptr = preaptr + ipre
20698*
20699 DO 50 ide = 1, ndest
20700 testnum = testnum + 1
20701 rdest2 = rdest0(ide)
20702 cdest2 = cdest0(ide)
20703*
20704* If everyone gets the answer, create some bogus rdest/cdest
20705* so IF's are easier
20706*
20707 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
20708 IF( allrcv ) THEN
20709 rdest = nprow - 1
20710 cdest = npcol - 1
20711 IF (topscohrnt.EQ.0) THEN
20712 itr1 = 0
20713 itr2 = 0
20714 ELSE IF (topscohrnt.EQ.1) THEN
20715 itr1 = 1
20716 itr2 = 1
20717 ELSE
20718 itr1 = 0
20719 itr2 = 1
20720 END IF
20721 ELSE
20722 rdest = rdest2
20723 cdest = cdest2
20724 itc1 = 0
20725 itc2 = 0
20726 END IF
20727 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
20728 nskip = nskip + 1
20729 GOTO 50
20730 END IF
20731*
20732 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
20733 lda = ldadst
20734 ELSE
20735 lda = ldasrc
20736 END IF
20737 valptr = aptr + ipost + n * lda
20738 IF( verb .GT. 1 ) THEN
20739 IF( iam .EQ. 0 ) THEN
20740 WRITE(outnum, 6000)
20741 $ testnum, 'RUNNING', scope, top, m, n,
20742 $ ldasrc, ldadst, ldi, rdest2, cdest2,
20743 $ nprow, npcol
20744 END IF
20745 END IF
20746*
20747* If I am in scope
20748*
20749 testok = .true.
20750 IF( ingrid ) THEN
20751 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
20752 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
20753 $ (scope .EQ. 'A') ) THEN
20754*
20755 k = nerr
20756 DO 40 itr = itr1, itr2
20757 CALL blacs_set(context, 15, itr)
20758 DO 35 itc = itc1, itc2
20759 CALL blacs_set(context, 16, itc)
20760 DO 30 j = istart, istop
20761 IF( j.EQ.0) GOTO 30
20762 IF( setwhat.NE.0 )
20763 $ CALL blacs_set(context, setwhat, j)
20764*
20765*
20766* generate and pad matrix A
20767*
20768 CALL cinitmat('G','-', m, n, mem(preaptr),
20769 $ lda, ipre, ipost,
20770 $ checkval, testnum,
20771 $ myrow, mycol )
20772*
20773* If they exist, pad RA and CA arrays
20774*
20775 IF( ldi .NE. -1 ) THEN
20776 DO 15 i = 1, n*ldi + ipre + ipost
20777 rmem(i) = icheckval
20778 cmem(i) = icheckval
20779 15 CONTINUE
20780 raptr = 1 + ipre
20781 captr = 1 + ipre
20782 ELSE
20783 DO 20 i = 1, ipre+ipost
20784 rmem(i) = icheckval
20785 cmem(i) = icheckval
20786 20 CONTINUE
20787 raptr = 1
20788 captr = 1
20789 END IF
20790*
20791 CALL cgamn2d(context, scope, top, m, n,
20792 $ mem(aptr), lda, rmem(raptr),
20793 $ cmem(captr), ldi,
20794 $ rdest2, cdest2)
20795*
20796* If I've got the answer, check for errors in
20797* matrix or padding
20798*
20799 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
20800 $ .OR. allrcv ) THEN
20801 CALL cchkpad('G','-', m, n,
20802 $ mem(preaptr), lda, rdest,
20803 $ cdest, myrow, mycol,
20804 $ ipre, ipost, checkval,
20805 $ testnum, maxerr, nerr,
20806 $ mem(erriptr),mem(errdptr))
20807 CALL cchkamn(scope, context, m, n,
20808 $ mem(aptr), lda,
20809 $ rmem(raptr), cmem(captr),
20810 $ ldi, testnum, maxerr,nerr,
20811 $ mem(erriptr),mem(errdptr),
20812 $ iseed, mem(valptr))
20813 CALL crcchk(ipre, ipost, icheckval,
20814 $ m, n, rmem, cmem, ldi,
20815 $ myrow, mycol, testnum,
20816 $ maxerr, nerr,
20817 $ mem(erriptr), mem(errdptr))
20818 END IF
20819 30 CONTINUE
20820 CALL blacs_set(context, 16, 0)
20821 35 CONTINUE
20822 CALL blacs_set(context, 15, 0)
20823 40 CONTINUE
20824 testok = ( k .EQ. nerr )
20825 END IF
20826 END IF
20827*
20828 IF( verb .GT. 1 ) THEN
20829 i = nerr
20830 CALL cbtcheckin(0, outnum, maxerr, nerr,
20831 $ mem(erriptr), mem(errdptr), iseed)
20832 IF( iam .EQ. 0 ) THEN
20833 IF( testok .AND. nerr.EQ.i ) THEN
20834 WRITE(outnum,6000)testnum,'PASSED ',
20835 $ scope, top, m, n, ldasrc,
20836 $ ldadst, ldi, rdest2, cdest2,
20837 $ nprow, npcol
20838 ELSE
20839 nfail = nfail + 1
20840 WRITE(outnum,6000)testnum,'FAILED ',
20841 $ scope, top, m, n, ldasrc,
20842 $ ldadst, ldi, rdest2, cdest2,
20843 $ nprow, npcol
20844 END IF
20845 END IF
20846*
20847* Once we've printed out errors, can re-use buf space
20848*
20849 nerr = 0
20850 END IF
20851 50 CONTINUE
20852 60 CONTINUE
20853 70 CONTINUE
20854 80 CONTINUE
20855 90 CONTINUE
20856*
20857 IF( verb .LT. 2 ) THEN
20858 nfail = testnum
20859 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
20860 $ mem(errdptr), iseed )
20861 END IF
20862 IF( iam .EQ. 0 ) THEN
20863 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
20864 IF( nfail+nskip .EQ. 0 ) THEN
20865 WRITE(outnum, 7000 ) testnum
20866 ELSE
20867 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
20868 $ nskip, nfail
20869 END IF
20870 END IF
20871*
20872* Log whether their were any failures
20873*
20874 testok = allpass( (nfail.EQ.0) )
20875*
20876 1000 FORMAT('COMPLEX AMN TESTS: BEGIN.' )
20877 2000 FORMAT(1x,a7,3x,10i6)
20878 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
20879 $ 5x,a1,5x,a1)
20880 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
20881 $ 'RDEST CDEST P Q')
20882 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
20883 $ '----- ----- ---- ----')
20884 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
20885 7000 FORMAT('COMPLEX AMN TESTS: PASSED ALL',
20886 $ i5, ' TESTS.')
20887 8000 FORMAT('COMPLEX AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
20888 $ i5,' SKIPPED,',i5,' FAILED.')
20889*
20890 RETURN
20891*
20892* End of CTESTAMN.
20893*
cmplx
float cmplx[2]
Definition pblas.h:136
crcchk
subroutine crcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:17331
cchkpad
subroutine cchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:9872
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
cinitmat
subroutine cinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:9591
cbtcheckin
subroutine cbtcheckin(nftests, outnum, maxerr, nerr, ierr, cval, tfailed)
Definition blacstest.f:9469
cchkamn
subroutine cchkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:20899
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: