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

◆ samxtest()

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

Definition at line 15230 of file blacstest.f.

15235*
15236* -- BLACS tester (version 1.0) --
15237* University of Tennessee
15238* December 15, 1994
15239*
15240*
15241* .. Scalar Arguments ..
15242 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
15243 $ TOPSCOHRNT, TOPSREPEAT, VERB
15244* ..
15245* .. Array Arguments ..
15246 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
15247 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
15248 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
15249 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
15250 REAL MEM(MEMLEN)
15251* ..
15252*
15253* Purpose
15254* =======
15255* STESTAMX: Test real AMX COMBINE
15256*
15257* Arguments
15258* =========
15259* OUTNUM (input) INTEGER
15260* The device number to write output to.
15261*
15262* VERB (input) INTEGER
15263* The level of verbosity (how much printing to do).
15264*
15265* NSCOPE (input) INTEGER
15266* The number of scopes to be tested.
15267*
15268* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
15269* Values of the scopes to be tested.
15270*
15271* NTOP (input) INTEGER
15272* The number of topologies to be tested.
15273*
15274* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
15275* Values of the topologies to be tested.
15276*
15277* NMAT (input) INTEGER
15278* The number of matrices to be tested.
15279*
15280* M0 (input) INTEGER array of dimension (NMAT)
15281* Values of M to be tested.
15282*
15283* M0 (input) INTEGER array of dimension (NMAT)
15284* Values of M to be tested.
15285*
15286* N0 (input) INTEGER array of dimension (NMAT)
15287* Values of N to be tested.
15288*
15289* LDAS0 (input) INTEGER array of dimension (NMAT)
15290* Values of LDAS (leading dimension of A on source process)
15291* to be tested.
15292*
15293* LDAD0 (input) INTEGER array of dimension (NMAT)
15294* Values of LDAD (leading dimension of A on destination
15295* process) to be tested.
15296* LDI0 (input) INTEGER array of dimension (NMAT)
15297* Values of LDI (leading dimension of RA/CA) to be tested.
15298* If LDI == -1, these RA/CA should not be accessed.
15299*
15300* NDEST (input) INTEGER
15301* The number of destinations to be tested.
15302*
15303* RDEST0 (input) INTEGER array of dimension (NNDEST)
15304* Values of RDEST (row coordinate of destination) to be
15305* tested.
15306*
15307* CDEST0 (input) INTEGER array of dimension (NNDEST)
15308* Values of CDEST (column coordinate of destination) to be
15309* tested.
15310*
15311* NGRID (input) INTEGER
15312* The number of process grids to be tested.
15313*
15314* CONTEXT0 (input) INTEGER array of dimension (NGRID)
15315* The BLACS context handles corresponding to the grids.
15316*
15317* P0 (input) INTEGER array of dimension (NGRID)
15318* Values of P (number of process rows, NPROW).
15319*
15320* Q0 (input) INTEGER array of dimension (NGRID)
15321* Values of Q (number of process columns, NPCOL).
15322*
15323* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
15324* Workspace used to hold each process's random number SEED.
15325* This requires NPROCS (number of processor) elements.
15326* If VERB < 2, this workspace also serves to indicate which
15327* tests fail. This requires workspace of NTESTS
15328* (number of tests performed).
15329*
15330* RMEM (workspace) INTEGER array of dimension (RCLEN)
15331* Used for all RA arrays, and their pre and post padding.
15332*
15333* CMEM (workspace) INTEGER array of dimension (RCLEN)
15334* Used for all CA arrays, and their pre and post padding.
15335*
15336* RCLEN (input) INTEGER
15337* The length, in elements, of RMEM and CMEM.
15338*
15339* MEM (workspace) REAL array of dimension (MEMLEN)
15340* Used for all other workspaces, including the matrix A,
15341* and its pre and post padding.
15342*
15343* MEMLEN (input) INTEGER
15344* The length, in elements, of MEM.
15345*
15346* =====================================================================
15347*
15348* .. External Functions ..
15349 LOGICAL ALLPASS, LSAME
15350 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
15351 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
15352* ..
15353* .. External Subroutines ..
15354 EXTERNAL blacs_gridinfo, sgamx2d
15355 EXTERNAL sinitmat, schkpad, sbtcheckin
15356* ..
15357* .. Local Scalars ..
15358 CHARACTER*1 SCOPE, TOP
15359 LOGICAL INGRID, TESTOK, ALLRCV
15360 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
15361 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
15362 $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
15363 $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
15364 $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
15365 $ RAPTR, RDEST, RDEST2, SETWHAT, SSIZE, TESTNUM, VALPTR
15366 REAL CHECKVAL
15367* ..
15368* .. Executable Statements ..
15369*
15370* Choose padding value, and make it unique
15371*
15372 checkval = -0.61e0
15373 iam = ibtmyproc()
15374 checkval = iam * checkval
15375 isize = ibtsizeof('I')
15376 ssize = ibtsizeof('S')
15377 icheckval = -iam
15378*
15379* Verify file parameters
15380*
15381 IF( iam .EQ. 0 ) THEN
15382 WRITE(outnum, *) ' '
15383 WRITE(outnum, *) ' '
15384 WRITE(outnum, 1000 )
15385 IF( verb .GT. 0 ) THEN
15386 WRITE(outnum,*) ' '
15387 WRITE(outnum, 2000) 'NSCOPE:', nscope
15388 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
15389 WRITE(outnum, 2000) 'TReps :', topsrepeat
15390 WRITE(outnum, 2000) 'TCohr :', topscohrnt
15391 WRITE(outnum, 2000) 'NTOP :', ntop
15392 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
15393 WRITE(outnum, 2000) 'NMAT :', nmat
15394 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
15395 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
15396 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
15397 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
15398 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
15399 WRITE(outnum, 2000) 'NDEST :', ndest
15400 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
15401 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
15402 WRITE(outnum, 2000) 'NGRIDS:', ngrid
15403 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
15404 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
15405 WRITE(outnum, 2000) 'VERB :', verb
15406 WRITE(outnum,*) ' '
15407 END IF
15408 IF( verb .GT. 1 ) THEN
15409 WRITE(outnum,4000)
15410 WRITE(outnum,5000)
15411 END IF
15412 END IF
15413 IF (topsrepeat.EQ.0) THEN
15414 itr1 = 0
15415 itr2 = 0
15416 ELSE IF (topsrepeat.EQ.1) THEN
15417 itr1 = 1
15418 itr2 = 1
15419 ELSE
15420 itr1 = 0
15421 itr2 = 1
15422 END IF
15423*
15424* Find biggest matrix, so we know where to stick error info
15425*
15426 i = 0
15427 DO 10 ima = 1, nmat
15428 ipad = 4 * m0(ima)
15429 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
15430 IF( k .GT. i ) i = k
15431 10 CONTINUE
15432 i = i + ibtnprocs()
15433 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
15434 IF( maxerr .LT. 1 ) THEN
15435 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
15436 CALL blacs_abort(-1, 1)
15437 END IF
15438 errdptr = i + 1
15439 erriptr = errdptr + maxerr
15440 nerr = 0
15441 testnum = 0
15442 nfail = 0
15443 nskip = 0
15444*
15445* Loop over grids of matrix
15446*
15447 DO 90 igr = 1, ngrid
15448*
15449* allocate process grid for the next batch of tests
15450*
15451 context = context0(igr)
15452 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
15453 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
15454*
15455 DO 80 isc = 1, nscope
15456 scope = scope0(isc)
15457 DO 70 ito = 1, ntop
15458 top = top0(ito)
15459*
15460* If testing multiring ('M') or general tree ('T'), need to
15461* loop over calls to BLACS_SET to do full test
15462*
15463 IF( lsame(top, 'M') ) THEN
15464 setwhat = 13
15465 IF( scope .EQ. 'R' ) THEN
15466 istart = -(npcol - 1)
15467 istop = -istart
15468 ELSE IF (scope .EQ. 'C') THEN
15469 istart = -(nprow - 1)
15470 istop = -istart
15471 ELSE
15472 istart = -(nprow*npcol - 1)
15473 istop = -istart
15474 ENDIF
15475 ELSE IF( lsame(top, 'T') ) THEN
15476 setwhat = 14
15477 istart = 1
15478 IF( scope .EQ. 'R' ) THEN
15479 istop = npcol - 1
15480 ELSE IF (scope .EQ. 'C') THEN
15481 istop = nprow - 1
15482 ELSE
15483 istop = nprow*npcol - 1
15484 ENDIF
15485 ELSE
15486 setwhat = 0
15487 istart = 1
15488 istop = 1
15489 ENDIF
15490 DO 60 ima = 1, nmat
15491 m = m0(ima)
15492 n = n0(ima)
15493 ldasrc = ldas0(ima)
15494 ldadst = ldad0(ima)
15495 ldi = ldi0(ima)
15496 ipre = 2 * m
15497 ipost = ipre
15498 preaptr = 1
15499 aptr = preaptr + ipre
15500*
15501 DO 50 ide = 1, ndest
15502 testnum = testnum + 1
15503 rdest2 = rdest0(ide)
15504 cdest2 = cdest0(ide)
15505*
15506* If everyone gets the answer, create some bogus rdest/cdest
15507* so IF's are easier
15508*
15509 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
15510 IF( allrcv ) THEN
15511 rdest = nprow - 1
15512 cdest = npcol - 1
15513 IF (topscohrnt.EQ.0) THEN
15514 itr1 = 0
15515 itr2 = 0
15516 ELSE IF (topscohrnt.EQ.1) THEN
15517 itr1 = 1
15518 itr2 = 1
15519 ELSE
15520 itr1 = 0
15521 itr2 = 1
15522 END IF
15523 ELSE
15524 rdest = rdest2
15525 cdest = cdest2
15526 itc1 = 0
15527 itc2 = 0
15528 END IF
15529 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
15530 nskip = nskip + 1
15531 GOTO 50
15532 END IF
15533*
15534 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
15535 lda = ldadst
15536 ELSE
15537 lda = ldasrc
15538 END IF
15539 valptr = aptr + ipost + n * lda
15540 IF( verb .GT. 1 ) THEN
15541 IF( iam .EQ. 0 ) THEN
15542 WRITE(outnum, 6000)
15543 $ testnum, 'RUNNING', scope, top, m, n,
15544 $ ldasrc, ldadst, ldi, rdest2, cdest2,
15545 $ nprow, npcol
15546 END IF
15547 END IF
15548*
15549* If I am in scope
15550*
15551 testok = .true.
15552 IF( ingrid ) THEN
15553 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
15554 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
15555 $ (scope .EQ. 'A') ) THEN
15556*
15557 k = nerr
15558 DO 40 itr = itr1, itr2
15559 CALL blacs_set(context, 15, itr)
15560 DO 35 itc = itc1, itc2
15561 CALL blacs_set(context, 16, itc)
15562 DO 30 j = istart, istop
15563 IF( j.EQ.0) GOTO 30
15564 IF( setwhat.NE.0 )
15565 $ CALL blacs_set(context, setwhat, j)
15566*
15567*
15568* generate and pad matrix A
15569*
15570 CALL sinitmat('G','-', m, n, mem(preaptr),
15571 $ lda, ipre, ipost,
15572 $ checkval, testnum,
15573 $ myrow, mycol )
15574*
15575* If they exist, pad RA and CA arrays
15576*
15577 IF( ldi .NE. -1 ) THEN
15578 DO 15 i = 1, n*ldi + ipre + ipost
15579 rmem(i) = icheckval
15580 cmem(i) = icheckval
15581 15 CONTINUE
15582 raptr = 1 + ipre
15583 captr = 1 + ipre
15584 ELSE
15585 DO 20 i = 1, ipre+ipost
15586 rmem(i) = icheckval
15587 cmem(i) = icheckval
15588 20 CONTINUE
15589 raptr = 1
15590 captr = 1
15591 END IF
15592*
15593 CALL sgamx2d(context, scope, top, m, n,
15594 $ mem(aptr), lda, rmem(raptr),
15595 $ cmem(captr), ldi,
15596 $ rdest2, cdest2)
15597*
15598* If I've got the answer, check for errors in
15599* matrix or padding
15600*
15601 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
15602 $ .OR. allrcv ) THEN
15603 CALL schkpad('G','-', m, n,
15604 $ mem(preaptr), lda, rdest,
15605 $ cdest, myrow, mycol,
15606 $ ipre, ipost, checkval,
15607 $ testnum, maxerr, nerr,
15608 $ mem(erriptr),mem(errdptr))
15609 CALL schkamx(scope, context, m, n,
15610 $ mem(aptr), lda,
15611 $ rmem(raptr), cmem(captr),
15612 $ ldi, testnum, maxerr,nerr,
15613 $ mem(erriptr),mem(errdptr),
15614 $ iseed, mem(valptr))
15615 CALL srcchk(ipre, ipost, icheckval,
15616 $ m, n, rmem, cmem, ldi,
15617 $ myrow, mycol, testnum,
15618 $ maxerr, nerr,
15619 $ mem(erriptr), mem(errdptr))
15620 END IF
15621 30 CONTINUE
15622 CALL blacs_set(context, 16, 0)
15623 35 CONTINUE
15624 CALL blacs_set(context, 15, 0)
15625 40 CONTINUE
15626 testok = ( k .EQ. nerr )
15627 END IF
15628 END IF
15629*
15630 IF( verb .GT. 1 ) THEN
15631 i = nerr
15632 CALL sbtcheckin(0, outnum, maxerr, nerr,
15633 $ mem(erriptr), mem(errdptr), iseed)
15634 IF( iam .EQ. 0 ) THEN
15635 IF( testok .AND. nerr.EQ.i ) THEN
15636 WRITE(outnum,6000)testnum,'PASSED ',
15637 $ scope, top, m, n, ldasrc,
15638 $ ldadst, ldi, rdest2, cdest2,
15639 $ nprow, npcol
15640 ELSE
15641 nfail = nfail + 1
15642 WRITE(outnum,6000)testnum,'FAILED ',
15643 $ scope, top, m, n, ldasrc,
15644 $ ldadst, ldi, rdest2, cdest2,
15645 $ nprow, npcol
15646 END IF
15647 END IF
15648*
15649* Once we've printed out errors, can re-use buf space
15650*
15651 nerr = 0
15652 END IF
15653 50 CONTINUE
15654 60 CONTINUE
15655 70 CONTINUE
15656 80 CONTINUE
15657 90 CONTINUE
15658*
15659 IF( verb .LT. 2 ) THEN
15660 nfail = testnum
15661 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
15662 $ mem(errdptr), iseed )
15663 END IF
15664 IF( iam .EQ. 0 ) THEN
15665 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
15666 IF( nfail+nskip .EQ. 0 ) THEN
15667 WRITE(outnum, 7000 ) testnum
15668 ELSE
15669 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
15670 $ nskip, nfail
15671 END IF
15672 END IF
15673*
15674* Log whether their were any failures
15675*
15676 testok = allpass( (nfail.EQ.0) )
15677*
15678 1000 FORMAT('REAL AMX TESTS: BEGIN.' )
15679 2000 FORMAT(1x,a7,3x,10i6)
15680 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
15681 $ 5x,a1,5x,a1)
15682 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
15683 $ 'RDEST CDEST P Q')
15684 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
15685 $ '----- ----- ---- ----')
15686 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
15687 7000 FORMAT('REAL AMX TESTS: PASSED ALL',
15688 $ i5, ' TESTS.')
15689 8000 FORMAT('REAL AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
15690 $ i5,' SKIPPED,',i5,' FAILED.')
15691*
15692 RETURN
15693*
15694* End of STESTAMX.
15695*
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
schkamx
subroutine schkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:15870
sinitmat
subroutine sinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:7463
srcchk
subroutine srcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:15701
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: