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

◆ iamxtest()

subroutine iamxtest ( 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 14381 of file blacstest.f.

14386*
14387* -- BLACS tester (version 1.0) --
14388* University of Tennessee
14389* December 15, 1994
14390*
14391*
14392* .. Scalar Arguments ..
14393 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
14394 $ TOPSCOHRNT, TOPSREPEAT, VERB
14395* ..
14396* .. Array Arguments ..
14397 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
14398 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
14399 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
14400 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
14401 INTEGER MEM(MEMLEN)
14402* ..
14403*
14404* Purpose
14405* =======
14406* ITESTAMX: Test integer AMX COMBINE
14407*
14408* Arguments
14409* =========
14410* OUTNUM (input) INTEGER
14411* The device number to write output to.
14412*
14413* VERB (input) INTEGER
14414* The level of verbosity (how much printing to do).
14415*
14416* NSCOPE (input) INTEGER
14417* The number of scopes to be tested.
14418*
14419* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
14420* Values of the scopes to be tested.
14421*
14422* NTOP (input) INTEGER
14423* The number of topologies to be tested.
14424*
14425* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
14426* Values of the topologies to be tested.
14427*
14428* NMAT (input) INTEGER
14429* The number of matrices to be tested.
14430*
14431* M0 (input) INTEGER array of dimension (NMAT)
14432* Values of M to be tested.
14433*
14434* M0 (input) INTEGER array of dimension (NMAT)
14435* Values of M to be tested.
14436*
14437* N0 (input) INTEGER array of dimension (NMAT)
14438* Values of N to be tested.
14439*
14440* LDAS0 (input) INTEGER array of dimension (NMAT)
14441* Values of LDAS (leading dimension of A on source process)
14442* to be tested.
14443*
14444* LDAD0 (input) INTEGER array of dimension (NMAT)
14445* Values of LDAD (leading dimension of A on destination
14446* process) to be tested.
14447* LDI0 (input) INTEGER array of dimension (NMAT)
14448* Values of LDI (leading dimension of RA/CA) to be tested.
14449* If LDI == -1, these RA/CA should not be accessed.
14450*
14451* NDEST (input) INTEGER
14452* The number of destinations to be tested.
14453*
14454* RDEST0 (input) INTEGER array of dimension (NNDEST)
14455* Values of RDEST (row coordinate of destination) to be
14456* tested.
14457*
14458* CDEST0 (input) INTEGER array of dimension (NNDEST)
14459* Values of CDEST (column coordinate of destination) to be
14460* tested.
14461*
14462* NGRID (input) INTEGER
14463* The number of process grids to be tested.
14464*
14465* CONTEXT0 (input) INTEGER array of dimension (NGRID)
14466* The BLACS context handles corresponding to the grids.
14467*
14468* P0 (input) INTEGER array of dimension (NGRID)
14469* Values of P (number of process rows, NPROW).
14470*
14471* Q0 (input) INTEGER array of dimension (NGRID)
14472* Values of Q (number of process columns, NPCOL).
14473*
14474* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
14475* Workspace used to hold each process's random number SEED.
14476* This requires NPROCS (number of processor) elements.
14477* If VERB < 2, this workspace also serves to indicate which
14478* tests fail. This requires workspace of NTESTS
14479* (number of tests performed).
14480*
14481* RMEM (workspace) INTEGER array of dimension (RCLEN)
14482* Used for all RA arrays, and their pre and post padding.
14483*
14484* CMEM (workspace) INTEGER array of dimension (RCLEN)
14485* Used for all CA arrays, and their pre and post padding.
14486*
14487* RCLEN (input) INTEGER
14488* The length, in elements, of RMEM and CMEM.
14489*
14490* MEM (workspace) INTEGER array of dimension (MEMLEN)
14491* Used for all other workspaces, including the matrix A,
14492* and its pre and post padding.
14493*
14494* MEMLEN (input) INTEGER
14495* The length, in elements, of MEM.
14496*
14497* =====================================================================
14498*
14499* .. External Functions ..
14500 LOGICAL ALLPASS, LSAME
14501 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
14502 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
14503* ..
14504* .. External Subroutines ..
14505 EXTERNAL blacs_gridinfo, igamx2d
14506 EXTERNAL iinitmat, ichkpad, ibtcheckin
14507* ..
14508* .. Local Scalars ..
14509 CHARACTER*1 SCOPE, TOP
14510 LOGICAL INGRID, TESTOK, ALLRCV
14511 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
14512 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
14513 $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
14514 $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
14515 $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
14516 $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
14517 INTEGER CHECKVAL
14518* ..
14519* .. Executable Statements ..
14520*
14521* Choose padding value, and make it unique
14522*
14523 checkval = -911
14524 iam = ibtmyproc()
14525 checkval = iam * checkval
14526 isize = ibtsizeof('I')
14527 icheckval = -iam
14528*
14529* Verify file parameters
14530*
14531 IF( iam .EQ. 0 ) THEN
14532 WRITE(outnum, *) ' '
14533 WRITE(outnum, *) ' '
14534 WRITE(outnum, 1000 )
14535 IF( verb .GT. 0 ) THEN
14536 WRITE(outnum,*) ' '
14537 WRITE(outnum, 2000) 'NSCOPE:', nscope
14538 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
14539 WRITE(outnum, 2000) 'TReps :', topsrepeat
14540 WRITE(outnum, 2000) 'TCohr :', topscohrnt
14541 WRITE(outnum, 2000) 'NTOP :', ntop
14542 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
14543 WRITE(outnum, 2000) 'NMAT :', nmat
14544 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
14545 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
14546 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
14547 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
14548 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
14549 WRITE(outnum, 2000) 'NDEST :', ndest
14550 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
14551 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
14552 WRITE(outnum, 2000) 'NGRIDS:', ngrid
14553 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
14554 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
14555 WRITE(outnum, 2000) 'VERB :', verb
14556 WRITE(outnum,*) ' '
14557 END IF
14558 IF( verb .GT. 1 ) THEN
14559 WRITE(outnum,4000)
14560 WRITE(outnum,5000)
14561 END IF
14562 END IF
14563 IF (topsrepeat.EQ.0) THEN
14564 itr1 = 0
14565 itr2 = 0
14566 ELSE IF (topsrepeat.EQ.1) THEN
14567 itr1 = 1
14568 itr2 = 1
14569 ELSE
14570 itr1 = 0
14571 itr2 = 1
14572 END IF
14573*
14574* Find biggest matrix, so we know where to stick error info
14575*
14576 i = 0
14577 DO 10 ima = 1, nmat
14578 ipad = 4 * m0(ima)
14579 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
14580 IF( k .GT. i ) i = k
14581 10 CONTINUE
14582 i = i + ibtnprocs()
14583 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
14584 IF( maxerr .LT. 1 ) THEN
14585 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
14586 CALL blacs_abort(-1, 1)
14587 END IF
14588 errdptr = i + 1
14589 erriptr = errdptr + maxerr
14590 nerr = 0
14591 testnum = 0
14592 nfail = 0
14593 nskip = 0
14594*
14595* Loop over grids of matrix
14596*
14597 DO 90 igr = 1, ngrid
14598*
14599* allocate process grid for the next batch of tests
14600*
14601 context = context0(igr)
14602 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
14603 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
14604*
14605 DO 80 isc = 1, nscope
14606 scope = scope0(isc)
14607 DO 70 ito = 1, ntop
14608 top = top0(ito)
14609*
14610* If testing multiring ('M') or general tree ('T'), need to
14611* loop over calls to BLACS_SET to do full test
14612*
14613 IF( lsame(top, 'M') ) THEN
14614 setwhat = 13
14615 IF( scope .EQ. 'R' ) THEN
14616 istart = -(npcol - 1)
14617 istop = -istart
14618 ELSE IF (scope .EQ. 'C') THEN
14619 istart = -(nprow - 1)
14620 istop = -istart
14621 ELSE
14622 istart = -(nprow*npcol - 1)
14623 istop = -istart
14624 ENDIF
14625 ELSE IF( lsame(top, 'T') ) THEN
14626 setwhat = 14
14627 istart = 1
14628 IF( scope .EQ. 'R' ) THEN
14629 istop = npcol - 1
14630 ELSE IF (scope .EQ. 'C') THEN
14631 istop = nprow - 1
14632 ELSE
14633 istop = nprow*npcol - 1
14634 ENDIF
14635 ELSE
14636 setwhat = 0
14637 istart = 1
14638 istop = 1
14639 ENDIF
14640 DO 60 ima = 1, nmat
14641 m = m0(ima)
14642 n = n0(ima)
14643 ldasrc = ldas0(ima)
14644 ldadst = ldad0(ima)
14645 ldi = ldi0(ima)
14646 ipre = 2 * m
14647 ipost = ipre
14648 preaptr = 1
14649 aptr = preaptr + ipre
14650*
14651 DO 50 ide = 1, ndest
14652 testnum = testnum + 1
14653 rdest2 = rdest0(ide)
14654 cdest2 = cdest0(ide)
14655*
14656* If everyone gets the answer, create some bogus rdest/cdest
14657* so IF's are easier
14658*
14659 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
14660 IF( allrcv ) THEN
14661 rdest = nprow - 1
14662 cdest = npcol - 1
14663 IF (topscohrnt.EQ.0) THEN
14664 itr1 = 0
14665 itr2 = 0
14666 ELSE IF (topscohrnt.EQ.1) THEN
14667 itr1 = 1
14668 itr2 = 1
14669 ELSE
14670 itr1 = 0
14671 itr2 = 1
14672 END IF
14673 ELSE
14674 rdest = rdest2
14675 cdest = cdest2
14676 itc1 = 0
14677 itc2 = 0
14678 END IF
14679 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
14680 nskip = nskip + 1
14681 GOTO 50
14682 END IF
14683*
14684 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
14685 lda = ldadst
14686 ELSE
14687 lda = ldasrc
14688 END IF
14689 valptr = aptr + ipost + n * lda
14690 IF( verb .GT. 1 ) THEN
14691 IF( iam .EQ. 0 ) THEN
14692 WRITE(outnum, 6000)
14693 $ testnum, 'RUNNING', scope, top, m, n,
14694 $ ldasrc, ldadst, ldi, rdest2, cdest2,
14695 $ nprow, npcol
14696 END IF
14697 END IF
14698*
14699* If I am in scope
14700*
14701 testok = .true.
14702 IF( ingrid ) THEN
14703 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
14704 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
14705 $ (scope .EQ. 'A') ) THEN
14706*
14707 k = nerr
14708 DO 40 itr = itr1, itr2
14709 CALL blacs_set(context, 15, itr)
14710 DO 35 itc = itc1, itc2
14711 CALL blacs_set(context, 16, itc)
14712 DO 30 j = istart, istop
14713 IF( j.EQ.0) GOTO 30
14714 IF( setwhat.NE.0 )
14715 $ CALL blacs_set(context, setwhat, j)
14716*
14717*
14718* generate and pad matrix A
14719*
14720 CALL iinitmat('G','-', m, n, mem(preaptr),
14721 $ lda, ipre, ipost,
14722 $ checkval, testnum,
14723 $ myrow, mycol )
14724*
14725* If they exist, pad RA and CA arrays
14726*
14727 IF( ldi .NE. -1 ) THEN
14728 DO 15 i = 1, n*ldi + ipre + ipost
14729 rmem(i) = icheckval
14730 cmem(i) = icheckval
14731 15 CONTINUE
14732 raptr = 1 + ipre
14733 captr = 1 + ipre
14734 ELSE
14735 DO 20 i = 1, ipre+ipost
14736 rmem(i) = icheckval
14737 cmem(i) = icheckval
14738 20 CONTINUE
14739 raptr = 1
14740 captr = 1
14741 END IF
14742*
14743 CALL igamx2d(context, scope, top, m, n,
14744 $ mem(aptr), lda, rmem(raptr),
14745 $ cmem(captr), ldi,
14746 $ rdest2, cdest2)
14747*
14748* If I've got the answer, check for errors in
14749* matrix or padding
14750*
14751 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
14752 $ .OR. allrcv ) THEN
14753 CALL ichkpad('G','-', m, n,
14754 $ mem(preaptr), lda, rdest,
14755 $ cdest, myrow, mycol,
14756 $ ipre, ipost, checkval,
14757 $ testnum, maxerr, nerr,
14758 $ mem(erriptr),mem(errdptr))
14759 CALL ichkamx(scope, context, m, n,
14760 $ mem(aptr), lda,
14761 $ rmem(raptr), cmem(captr),
14762 $ ldi, testnum, maxerr,nerr,
14763 $ mem(erriptr),mem(errdptr),
14764 $ iseed, mem(valptr))
14765 CALL ircchk(ipre, ipost, icheckval,
14766 $ m, n, rmem, cmem, ldi,
14767 $ myrow, mycol, testnum,
14768 $ maxerr, nerr,
14769 $ mem(erriptr), mem(errdptr))
14770 END IF
14771 30 CONTINUE
14772 CALL blacs_set(context, 16, 0)
14773 35 CONTINUE
14774 CALL blacs_set(context, 15, 0)
14775 40 CONTINUE
14776 testok = ( k .EQ. nerr )
14777 END IF
14778 END IF
14779*
14780 IF( verb .GT. 1 ) THEN
14781 i = nerr
14782 CALL ibtcheckin(0, outnum, maxerr, nerr,
14783 $ mem(erriptr), mem(errdptr), iseed)
14784 IF( iam .EQ. 0 ) THEN
14785 IF( testok .AND. nerr.EQ.i ) THEN
14786 WRITE(outnum,6000)testnum,'PASSED ',
14787 $ scope, top, m, n, ldasrc,
14788 $ ldadst, ldi, rdest2, cdest2,
14789 $ nprow, npcol
14790 ELSE
14791 nfail = nfail + 1
14792 WRITE(outnum,6000)testnum,'FAILED ',
14793 $ scope, top, m, n, ldasrc,
14794 $ ldadst, ldi, rdest2, cdest2,
14795 $ nprow, npcol
14796 END IF
14797 END IF
14798*
14799* Once we've printed out errors, can re-use buf space
14800*
14801 nerr = 0
14802 END IF
14803 50 CONTINUE
14804 60 CONTINUE
14805 70 CONTINUE
14806 80 CONTINUE
14807 90 CONTINUE
14808*
14809 IF( verb .LT. 2 ) THEN
14810 nfail = testnum
14811 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
14812 $ mem(errdptr), iseed )
14813 END IF
14814 IF( iam .EQ. 0 ) THEN
14815 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
14816 IF( nfail+nskip .EQ. 0 ) THEN
14817 WRITE(outnum, 7000 ) testnum
14818 ELSE
14819 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
14820 $ nskip, nfail
14821 END IF
14822 END IF
14823*
14824* Log whether their were any failures
14825*
14826 testok = allpass( (nfail.EQ.0) )
14827*
14828 1000 FORMAT('INTEGER AMX TESTS: BEGIN.' )
14829 2000 FORMAT(1x,a7,3x,10i6)
14830 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
14831 $ 5x,a1,5x,a1)
14832 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
14833 $ 'RDEST CDEST P Q')
14834 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
14835 $ '----- ----- ---- ----')
14836 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
14837 7000 FORMAT('INTEGER AMX TESTS: PASSED ALL',
14838 $ i5, ' TESTS.')
14839 8000 FORMAT('INTEGER AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
14840 $ i5,' SKIPPED,',i5,' FAILED.')
14841*
14842 RETURN
14843*
14844* End of ITESTAMX.
14845*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
ichkamx
subroutine ichkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:15058
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
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: