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

◆ isdrvtest()

subroutine isdrvtest ( integer  outnum,
integer  verb,
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, dimension(nsrc)  rdest0,
integer, dimension(nsrc)  cdest0,
integer  ngrid,
integer, dimension(ngrid)  context0,
integer, dimension(ngrid)  p0,
integer, dimension(ngrid)  q0,
integer, dimension(*)  tfail,
integer, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 2201 of file blacstest.f.

2205*
2206* -- BLACS tester (version 1.0) --
2207* University of Tennessee
2208* December 15, 1994
2209*
2210*
2211* .. Scalar Arguments ..
2212 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2213* ..
2214* .. Array Arguments ..
2215 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2216 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2217 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2218 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2219 INTEGER MEM(MEMLEN)
2220* ..
2221*
2222* Purpose
2223* =======
2224* ITESTSDRV: Test integer send/recv
2225*
2226* Arguments
2227* =========
2228* OUTNUM (input) INTEGER
2229* The device number to write output to.
2230*
2231* VERB (input) INTEGER
2232* The level of verbosity (how much printing to do).
2233*
2234* NSHAPE (input) INTEGER
2235* The number of matrix shapes to be tested.
2236*
2237* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2238* Values of UPLO to be tested.
2239*
2240* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2241* Values of DIAG to be tested.
2242*
2243* NMAT (input) INTEGER
2244* The number of matrices to be tested.
2245*
2246* M0 (input) INTEGER array of dimension (NMAT)
2247* Values of M to be tested.
2248*
2249* M0 (input) INTEGER array of dimension (NMAT)
2250* Values of M to be tested.
2251*
2252* N0 (input) INTEGER array of dimension (NMAT)
2253* Values of N to be tested.
2254*
2255* LDAS0 (input) INTEGER array of dimension (NMAT)
2256* Values of LDAS (leading dimension of A on source process)
2257* to be tested.
2258*
2259* LDAD0 (input) INTEGER array of dimension (NMAT)
2260* Values of LDAD (leading dimension of A on destination
2261* process) to be tested.
2262* NSRC (input) INTEGER
2263* The number of sources to be tested.
2264*
2265* RSRC0 (input) INTEGER array of dimension (NDEST)
2266* Values of RSRC (row coordinate of source) to be tested.
2267*
2268* CSRC0 (input) INTEGER array of dimension (NDEST)
2269* Values of CSRC (column coordinate of source) to be tested.
2270*
2271* RDEST0 (input) INTEGER array of dimension (NNSRC)
2272* Values of RDEST (row coordinate of destination) to be
2273* tested.
2274*
2275* CDEST0 (input) INTEGER array of dimension (NNSRC)
2276* Values of CDEST (column coordinate of destination) to be
2277* tested.
2278*
2279* NGRID (input) INTEGER
2280* The number of process grids to be tested.
2281*
2282* CONTEXT0 (input) INTEGER array of dimension (NGRID)
2283* The BLACS context handles corresponding to the grids.
2284*
2285* P0 (input) INTEGER array of dimension (NGRID)
2286* Values of P (number of process rows, NPROW).
2287*
2288* Q0 (input) INTEGER array of dimension (NGRID)
2289* Values of Q (number of process columns, NPCOL).
2290*
2291* TFAIL (workspace) INTEGER array of dimension (NTESTS)
2292* If VERB < 2, serves to indicate which tests fail. This
2293* requires workspace of NTESTS (number of tests performed).
2294*
2295* MEM (workspace) INTEGER array of dimension (MEMLEN)
2296* Used for all other workspaces, including the matrix A,
2297* and its pre and post padding.
2298*
2299* MEMLEN (input) INTEGER
2300* The length, in elements, of MEM.
2301*
2302* =====================================================================
2303*
2304* .. External Functions ..
2305 LOGICAL ALLPASS
2306 INTEGER IBTMYPROC, IBTSIZEOF
2307 EXTERNAL allpass, ibtmyproc, ibtsizeof
2308* ..
2309* .. External Subroutines ..
2310 EXTERNAL blacs_gridinfo
2311 EXTERNAL itrsd2d, igesd2d, itrrv2d, igerv2d
2312 EXTERNAL iinitmat, ichkmat, ichkpad, ibtcheckin
2313* ..
2314* .. Local Scalars ..
2315 CHARACTER*1 UPLO, DIAG
2316 LOGICAL TESTOK
2317 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
2318 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
2319 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
2320 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
2321 INTEGER SCHECKVAL, RCHECKVAL
2322* ..
2323* .. Executable Statements ..
2324*
2325 scheckval = -1
2326 rcheckval = -2
2327*
2328 iam = ibtmyproc()
2329 isize = ibtsizeof('I')
2330 isize = ibtsizeof('I')
2331*
2332* Verify file parameters
2333*
2334 IF( iam .EQ. 0 ) THEN
2335 WRITE(outnum, *) ' '
2336 WRITE(outnum, *) ' '
2337 WRITE(outnum, 1000 )
2338 IF( verb .GT. 0 ) THEN
2339 WRITE(outnum,*) ' '
2340 WRITE(outnum, 2000) 'NSHAPE:', nshape
2341 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
2342 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
2343 WRITE(outnum, 2000) 'NMAT :', nmat
2344 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
2345 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
2346 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
2347 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
2348 WRITE(outnum, 2000) 'NSRC :', nsrc
2349 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
2350 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
2351 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
2352 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
2353 WRITE(outnum, 2000) 'NGRIDS:', ngrid
2354 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
2355 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
2356 WRITE(outnum, 2000) 'VERB :', verb
2357 WRITE(outnum,*) ' '
2358 END IF
2359 IF( verb .GT. 1 ) THEN
2360 WRITE(outnum,5000)
2361 WRITE(outnum,6000)
2362 END IF
2363 END IF
2364*
2365* Find biggest matrix, so we know where to stick error info
2366*
2367 i = 0
2368 DO 10 ima = 1, nmat
2369 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2370 IF( k .GT. i ) i = k
2371 10 CONTINUE
2372 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
2373 IF( maxerr .LT. 1 ) THEN
2374 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
2375 CALL blacs_abort(-1, 1)
2376 END IF
2377 errdptr = i + 1
2378 erriptr = errdptr + maxerr
2379 nerr = 0
2380 testnum = 0
2381 nfail = 0
2382 nskip = 0
2383*
2384* Loop over grids of matrix
2385*
2386 DO 110 igr = 1, ngrid
2387*
2388 context = context0(igr)
2389 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2390*
2391 DO 80 ish = 1, nshape
2392 uplo = uplo0(ish)
2393 diag = diag0(ish)
2394*
2395 DO 70 ima = 1, nmat
2396 m = m0(ima)
2397 n = n0(ima)
2398 ldasrc = ldas0(ima)
2399 ldadst = ldad0(ima)
2400*
2401 DO 60 iso = 1, nsrc
2402 testnum = testnum + 1
2403 rsrc = rsrc0(iso)
2404 csrc = csrc0(iso)
2405 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
2406 nskip = nskip + 1
2407 GOTO 60
2408 END IF
2409 rdest = rdest0(iso)
2410 cdest = cdest0(iso)
2411 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
2412 nskip = nskip + 1
2413 GOTO 60
2414 END IF
2415*
2416 IF( verb .GT. 1 ) THEN
2417 IF( iam .EQ. 0 ) THEN
2418 WRITE(outnum, 7000) testnum, 'RUNNING',
2419 $ uplo, diag, m, n,
2420 $ ldasrc, ldadst, rsrc, csrc,
2421 $ rdest, cdest, nprow, npcol
2422 END IF
2423 END IF
2424*
2425 testok = .true.
2426 ipre = 2 * m
2427 ipost = ipre
2428 aptr = ipre + 1
2429*
2430* source process generates matrix and sends it
2431*
2432 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
2433 CALL iinitmat( uplo, diag, m, n, mem, ldasrc,
2434 $ ipre, ipost, scheckval, testnum,
2435 $ myrow, mycol )
2436*
2437 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2438 CALL itrsd2d( context, uplo, diag, m, n,
2439 $ mem(aptr), ldasrc, rdest, cdest )
2440 ELSE
2441 CALL igesd2d( context, m, n, mem(aptr),
2442 $ ldasrc, rdest, cdest )
2443 END IF
2444 END IF
2445*
2446 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
2447*
2448* Pad entire matrix area
2449*
2450 DO 50 k = 1, ipre+ipost+ldadst*n
2451 mem(k) = rcheckval
2452 50 CONTINUE
2453*
2454* Receive matrix
2455*
2456 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2457 CALL itrrv2d( context, uplo, diag, m, n,
2458 $ mem(aptr), ldadst, rsrc, csrc )
2459 ELSE
2460 CALL igerv2d( context, m, n, mem(aptr),
2461 $ ldadst, rsrc, csrc )
2462 END IF
2463*
2464* Check for errors in matrix or padding
2465*
2466 i = nerr
2467 CALL ichkmat( uplo, diag, m, n, mem(aptr), ldadst,
2468 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2469 $ nerr, mem(erriptr), mem(errdptr) )
2470*
2471 CALL ichkpad( uplo, diag, m, n, mem, ldadst,
2472 $ rsrc, csrc, myrow, mycol, ipre, ipost,
2473 $ rcheckval, testnum, maxerr, nerr,
2474 $ mem(erriptr), mem(errdptr) )
2475 testok = i .EQ. nerr
2476 END IF
2477*
2478 IF( verb .GT. 1 ) THEN
2479 i = nerr
2480 CALL ibtcheckin( 0, outnum, maxerr, nerr,
2481 $ mem(erriptr), mem(errdptr),
2482 $ tfail )
2483 IF( iam .EQ. 0 ) THEN
2484 IF( testok .AND. i.EQ.nerr ) THEN
2485 WRITE(outnum, 7000) testnum, 'PASSED ',
2486 $ uplo, diag, m, n, ldasrc, ldadst,
2487 $ rsrc, csrc, rdest, cdest, nprow, npcol
2488 ELSE
2489 nfail = nfail + 1
2490 WRITE(outnum, 7000) testnum, 'FAILED ',
2491 $ uplo, diag, m, n, ldasrc, ldadst,
2492 $ rsrc, csrc, rdest, cdest, nprow, npcol
2493 ENDIF
2494 END IF
2495*
2496* Once we've printed out errors, can re-use buf space
2497*
2498 nerr = 0
2499 END IF
2500 60 CONTINUE
2501 70 CONTINUE
2502 80 CONTINUE
2503 110 CONTINUE
2504*
2505 IF( verb .LT. 2 ) THEN
2506 nfail = testnum
2507 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2508 $ mem(errdptr), tfail )
2509 END IF
2510 IF( iam .EQ. 0 ) THEN
2511 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
2512 IF( nfail+nskip .EQ. 0 ) THEN
2513 WRITE(outnum, 8000 ) testnum
2514 ELSE
2515 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2516 $ nskip, nfail
2517 END IF
2518 END IF
2519*
2520* Log whether their were any failures
2521*
2522 testok = allpass( (nfail.EQ.0) )
2523*
2524 1000 FORMAT('INTEGER SDRV TESTS: BEGIN.' )
2525 2000 FORMAT(1x,a7,3x,10i6)
2526 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
2527 $ 5x,a1,5x,a1)
2528 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
2529 $ 'CSRC RDEST CDEST P Q')
2530 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
2531 $ '---- ----- ----- ---- ----')
2532 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
2533 8000 FORMAT('INTEGER SDRV TESTS: PASSED ALL',
2534 $ i5, ' TESTS.')
2535 9000 FORMAT('INTEGER SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
2536 $ i5,' SKIPPED,',i5,' FAILED.')
2537*
2538 RETURN
2539*
2540* End of ISDRVTEST.
2541*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
ichkmat
subroutine ichkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:6943
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
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
ibtsizeof
integer function ibtsizeof(type)
Definition btprim.f:286
Here is the caller graph for this function: