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

◆ sbsbrtest()

subroutine sbsbrtest ( integer  outnum,
integer  verb,
integer  nscope,
character*1, dimension(nscope)  scope0,
integer  ntop,
character*1, dimension(ntop)  top0,
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  ngrid,
integer, dimension(ngrid)  context0,
integer, dimension(ngrid)  p0,
integer, dimension(ngrid)  q0,
integer, dimension(*)  tfail,
real, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 4336 of file blacstest.f.

4340*
4341* -- BLACS tester (version 1.0) --
4342* University of Tennessee
4343* December 15, 1994
4344*
4345*
4346* .. Scalar Arguments ..
4347 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
4348 INTEGER MEMLEN
4349* ..
4350* .. Array Arguments ..
4351 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
4352 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
4353 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
4354 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
4355 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
4356 REAL MEM(MEMLEN)
4357* ..
4358*
4359* Purpose
4360* =======
4361* STESTBSBR: Test real broadcast
4362*
4363* Arguments
4364* =========
4365* OUTNUM (input) INTEGER
4366* The device number to write output to.
4367*
4368* VERB (input) INTEGER
4369* The level of verbosity (how much printing to do).
4370*
4371* NSCOPE (input) INTEGER
4372* The number of scopes to be tested.
4373*
4374* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
4375* Values of the scopes to be tested.
4376*
4377* NTOP (input) INTEGER
4378* The number of topologies to be tested.
4379*
4380* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
4381* Values of the topologies to be tested.
4382*
4383* NSHAPE (input) INTEGER
4384* The number of matrix shapes to be tested.
4385*
4386* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
4387* Values of UPLO to be tested.
4388*
4389* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
4390* Values of DIAG to be tested.
4391*
4392* NMAT (input) INTEGER
4393* The number of matrices to be tested.
4394*
4395* M0 (input) INTEGER array of dimension (NMAT)
4396* Values of M to be tested.
4397*
4398* M0 (input) INTEGER array of dimension (NMAT)
4399* Values of M to be tested.
4400*
4401* N0 (input) INTEGER array of dimension (NMAT)
4402* Values of N to be tested.
4403*
4404* LDAS0 (input) INTEGER array of dimension (NMAT)
4405* Values of LDAS (leading dimension of A on source process)
4406* to be tested.
4407*
4408* LDAD0 (input) INTEGER array of dimension (NMAT)
4409* Values of LDAD (leading dimension of A on destination
4410* process) to be tested.
4411* NSRC (input) INTEGER
4412* The number of sources to be tested.
4413*
4414* RSRC0 (input) INTEGER array of dimension (NDEST)
4415* Values of RSRC (row coordinate of source) to be tested.
4416*
4417* CSRC0 (input) INTEGER array of dimension (NDEST)
4418* Values of CSRC (column coordinate of source) to be tested.
4419*
4420* NGRID (input) INTEGER
4421* The number of process grids to be tested.
4422*
4423* CONTEXT0 (input) INTEGER array of dimension (NGRID)
4424* The BLACS context handles corresponding to the grids.
4425*
4426* P0 (input) INTEGER array of dimension (NGRID)
4427* Values of P (number of process rows, NPROW).
4428*
4429* Q0 (input) INTEGER array of dimension (NGRID)
4430* Values of Q (number of process columns, NPCOL).
4431*
4432* TFAIL (workspace) INTEGER array of dimension (NTESTS)
4433* If VERB < 2, serves to indicate which tests fail. This
4434* requires workspace of NTESTS (number of tests performed).
4435*
4436* MEM (workspace) REAL array of dimension (MEMLEN)
4437* Used for all other workspaces, including the matrix A,
4438* and its pre and post padding.
4439*
4440* MEMLEN (input) INTEGER
4441* The length, in elements, of MEM.
4442*
4443* =====================================================================
4444*
4445* .. External Functions ..
4446 LOGICAL ALLPASS, LSAME
4447 INTEGER IBTMYPROC, IBTSIZEOF
4448 EXTERNAL allpass, lsame, ibtmyproc, ibtsizeof
4449* ..
4450* .. External Subroutines ..
4451 EXTERNAL blacs_gridinfo
4452 EXTERNAL strbs2d, sgebs2d, strbr2d, sgebr2d
4453 EXTERNAL sinitmat, schkmat, schkpad, sbtcheckin
4454* ..
4455* .. Local Scalars ..
4456 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4457 LOGICAL TESTOK, INGRID
4458 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4459 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4460 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4461 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4462 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
4463 REAL SCHECKVAL, RCHECKVAL
4464* ..
4465* .. Executable Statements ..
4466*
4467 scheckval = -0.01e0
4468 rcheckval = -0.02e0
4469*
4470 iam = ibtmyproc()
4471 isize = ibtsizeof('I')
4472 ssize = ibtsizeof('S')
4473*
4474* Verify file parameters
4475*
4476 IF( iam .EQ. 0 ) THEN
4477 WRITE(outnum, *) ' '
4478 WRITE(outnum, *) ' '
4479 WRITE(outnum, 1000 )
4480 IF( verb .GT. 0 ) THEN
4481 WRITE(outnum,*) ' '
4482 WRITE(outnum, 2000) 'NSCOPE:', nscope
4483 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4484 WRITE(outnum, 2000) 'NTOP :', ntop
4485 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4486 WRITE(outnum, 2000) 'NSHAPE:', nshape
4487 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4488 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4489 WRITE(outnum, 2000) 'NMAT :', nmat
4490 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4491 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4492 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4493 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4494 WRITE(outnum, 2000) 'NSRC :', nsrc
4495 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4496 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4497 WRITE(outnum, 2000) 'NGRIDS:', ngrid
4498 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4499 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4500 WRITE(outnum, 2000) 'VERB :', verb
4501 WRITE(outnum,*) ' '
4502 END IF
4503 IF( verb .GT. 1 ) THEN
4504 WRITE(outnum,5000)
4505 WRITE(outnum,6000)
4506 END IF
4507 END IF
4508*
4509* Find biggest matrix, so we know where to stick error info
4510*
4511 i = 0
4512 DO 10 ima = 1, nmat
4513 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4514 IF( k .GT. i ) i = k
4515 10 CONTINUE
4516 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
4517 IF( maxerr .LT. 1 ) THEN
4518 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4519 CALL blacs_abort(-1, 1)
4520 END IF
4521 errdptr = i + 1
4522 erriptr = errdptr + maxerr
4523 nerr = 0
4524 testnum = 0
4525 nfail = 0
4526 nskip = 0
4527*
4528* Loop over grids of matrix
4529*
4530 DO 110 igr = 1, ngrid
4531*
4532 context = context0(igr)
4533 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4534*
4535 ingrid = ( nprow .GT. 0 )
4536*
4537 DO 100 isc = 1, nscope
4538 scope = scope0(isc)
4539 DO 90 ito = 1, ntop
4540 top = top0(ito)
4541*
4542* If testing multipath ('M') or general tree ('T'),
4543* need to loop over calls to BLACS_SET
4544*
4545 IF( lsame(top, 'M') ) THEN
4546 setwhat = 11
4547 IF( scope .EQ. 'R' ) THEN
4548 istart = -(npcol - 1)
4549 istop = -istart
4550 ELSE IF (scope .EQ. 'C') THEN
4551 istart = -(nprow - 1)
4552 istop = -istart
4553 ELSE
4554 istart = -(nprow*npcol - 1)
4555 istop = -istart
4556 ENDIF
4557 ELSE IF( lsame(top, 'T') ) THEN
4558 setwhat = 12
4559 istart = 1
4560 IF( scope .EQ. 'R' ) THEN
4561 istop = npcol - 1
4562 ELSE IF (scope .EQ. 'C') THEN
4563 istop = nprow - 1
4564 ELSE
4565 istop = nprow*npcol - 1
4566 ENDIF
4567 ELSE
4568 setwhat = 0
4569 istart = 1
4570 istop = 1
4571 ENDIF
4572 DO 80 ish = 1, nshape
4573 uplo = uplo0(ish)
4574 diag = diag0(ish)
4575*
4576 DO 70 ima = 1, nmat
4577 m = m0(ima)
4578 n = n0(ima)
4579 ldasrc = ldas0(ima)
4580 ldadst = ldad0(ima)
4581*
4582 DO 60 iso = 1, nsrc
4583 testnum = testnum + 1
4584 rsrc = rsrc0(iso)
4585 csrc = csrc0(iso)
4586 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
4587 nskip = nskip + 1
4588 GOTO 60
4589 END IF
4590 IF( verb .GT. 1 ) THEN
4591 IF( iam .EQ. 0 ) THEN
4592 WRITE(outnum, 7000)
4593 $ testnum, 'RUNNING',scope, top, uplo, diag,
4594 $ m, n, ldasrc, ldadst, rsrc, csrc,
4595 $ nprow, npcol
4596 END IF
4597 END IF
4598*
4599 testok = .true.
4600 ipre = 2 * m
4601 ipost = ipre
4602 aptr = ipre + 1
4603*
4604* If I am in scope
4605*
4606 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
4607 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
4608 $ (scope .EQ. 'A') ) THEN
4609*
4610* source process generates matrix and sends it
4611*
4612 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
4613 CALL sinitmat(uplo, diag, m, n, mem,
4614 $ ldasrc, ipre, ipost,
4615 $ scheckval, testnum,
4616 $ myrow, mycol )
4617*
4618 DO 20 j = istart, istop
4619 IF( j.EQ.0 ) GOTO 20
4620 IF( setwhat.NE.0 )
4621 $ CALL blacs_set(context, setwhat, j)
4622 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4623 CALL strbs2d(context, scope, top,
4624 $ uplo, diag, m, n,
4625 $ mem(aptr), ldasrc )
4626 ELSE
4627 CALL sgebs2d(context, scope, top,
4628 $ m, n, mem(aptr),
4629 $ ldasrc )
4630 END IF
4631 20 CONTINUE
4632*
4633* Destination processes
4634*
4635 ELSE IF( ingrid ) THEN
4636 DO 40 j = istart, istop
4637 IF( j.EQ.0 ) GOTO 40
4638 IF( setwhat.NE.0 )
4639 $ CALL blacs_set(context, setwhat, j)
4640*
4641* Pad entire matrix area
4642*
4643 DO 30 k = 1, ipre+ipost+ldadst*n
4644 mem(k) = rcheckval
4645 30 CONTINUE
4646*
4647* Receive matrix
4648*
4649 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4650 CALL strbr2d(context, scope, top,
4651 $ uplo, diag, m, n,
4652 $ mem(aptr), ldadst,
4653 $ rsrc, csrc)
4654 ELSE
4655 CALL sgebr2d(context, scope, top,
4656 $ m, n, mem(aptr),
4657 $ ldadst, rsrc, csrc)
4658 END IF
4659*
4660* Check for errors in matrix or padding
4661*
4662 i = nerr
4663 CALL schkmat(uplo, diag, m, n,
4664 $ mem(aptr), ldadst, rsrc, csrc,
4665 $ myrow, mycol, testnum, maxerr,
4666 $ nerr, mem(erriptr),
4667 $ mem(errdptr))
4668*
4669 CALL schkpad(uplo, diag, m, n, mem,
4670 $ ldadst, rsrc, csrc, myrow,
4671 $ mycol, ipre, ipost, rcheckval,
4672 $ testnum, maxerr, nerr,
4673 $ mem(erriptr), mem(errdptr))
4674 40 CONTINUE
4675 testok = ( i .EQ. nerr )
4676 END IF
4677 END IF
4678*
4679 IF( verb .GT. 1 ) THEN
4680 i = nerr
4681 CALL sbtcheckin(0, outnum, maxerr, nerr,
4682 $ mem(erriptr), mem(errdptr),
4683 $ tfail)
4684 IF( iam .EQ. 0 ) THEN
4685 testok = ( testok .AND. (i.EQ.nerr) )
4686 IF( testok ) THEN
4687 WRITE(outnum,7000)testnum,'PASSED ',
4688 $ scope, top, uplo, diag, m, n,
4689 $ ldasrc, ldadst, rsrc, csrc,
4690 $ nprow, npcol
4691 ELSE
4692 nfail = nfail + 1
4693 WRITE(outnum,7000)testnum,'FAILED ',
4694 $ scope, top, uplo, diag, m, n,
4695 $ ldasrc, ldadst, rsrc, csrc,
4696 $ nprow, npcol
4697 END IF
4698 END IF
4699*
4700* Once we've printed out errors, can re-use buf space
4701*
4702 nerr = 0
4703 END IF
4704 60 CONTINUE
4705 70 CONTINUE
4706 80 CONTINUE
4707 90 CONTINUE
4708 100 CONTINUE
4709 110 CONTINUE
4710*
4711 IF( verb .LT. 2 ) THEN
4712 nfail = testnum
4713 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4714 $ mem(errdptr), tfail )
4715 END IF
4716 IF( iam .EQ. 0 ) THEN
4717 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
4718 IF( nfail+nskip .EQ. 0 ) THEN
4719 WRITE(outnum, 8000 ) testnum
4720 ELSE
4721 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4722 $ nskip, nfail
4723 END IF
4724 END IF
4725*
4726* Log whether their were any failures
4727*
4728 testok = allpass( (nfail.EQ.0) )
4729*
4730 1000 FORMAT('REAL BSBR TESTS: BEGIN.' )
4731 2000 FORMAT(1x,a7,3x,10i6)
4732 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
4733 $ 5x,a1,5x,a1)
4734 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
4735 $ ' LDAD RSRC CSRC P Q')
4736 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
4737 $ '----- ---- ---- ---- ----')
4738 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
4739 8000 FORMAT('REAL BSBR TESTS: PASSED ALL',
4740 $ i5, ' TESTS.')
4741 9000 FORMAT('REAL BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
4742 $ i5,' SKIPPED,',i5,' FAILED.')
4743*
4744 RETURN
4745*
4746* End of SBSBRTEST.
4747*
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
sinitmat
subroutine sinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:7463
schkmat
subroutine schkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:8007
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 caller graph for this function: