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

◆ csdrvtest()

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

Definition at line 3233 of file blacstest.f.

3237*
3238* -- BLACS tester (version 1.0) --
3239* University of Tennessee
3240* December 15, 1994
3241*
3242*
3243* .. Scalar Arguments ..
3244 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
3245* ..
3246* .. Array Arguments ..
3247 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3248 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3249 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
3250 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
3251 COMPLEX MEM(MEMLEN)
3252* ..
3253*
3254* Purpose
3255* =======
3256* CTESTSDRV: Test complex send/recv
3257*
3258* Arguments
3259* =========
3260* OUTNUM (input) INTEGER
3261* The device number to write output to.
3262*
3263* VERB (input) INTEGER
3264* The level of verbosity (how much printing to do).
3265*
3266* NSHAPE (input) INTEGER
3267* The number of matrix shapes to be tested.
3268*
3269* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3270* Values of UPLO to be tested.
3271*
3272* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3273* Values of DIAG to be tested.
3274*
3275* NMAT (input) INTEGER
3276* The number of matrices to be tested.
3277*
3278* M0 (input) INTEGER array of dimension (NMAT)
3279* Values of M to be tested.
3280*
3281* M0 (input) INTEGER array of dimension (NMAT)
3282* Values of M to be tested.
3283*
3284* N0 (input) INTEGER array of dimension (NMAT)
3285* Values of N to be tested.
3286*
3287* LDAS0 (input) INTEGER array of dimension (NMAT)
3288* Values of LDAS (leading dimension of A on source process)
3289* to be tested.
3290*
3291* LDAD0 (input) INTEGER array of dimension (NMAT)
3292* Values of LDAD (leading dimension of A on destination
3293* process) to be tested.
3294* NSRC (input) INTEGER
3295* The number of sources to be tested.
3296*
3297* RSRC0 (input) INTEGER array of dimension (NDEST)
3298* Values of RSRC (row coordinate of source) to be tested.
3299*
3300* CSRC0 (input) INTEGER array of dimension (NDEST)
3301* Values of CSRC (column coordinate of source) to be tested.
3302*
3303* RDEST0 (input) INTEGER array of dimension (NNSRC)
3304* Values of RDEST (row coordinate of destination) to be
3305* tested.
3306*
3307* CDEST0 (input) INTEGER array of dimension (NNSRC)
3308* Values of CDEST (column coordinate of destination) to be
3309* tested.
3310*
3311* NGRID (input) INTEGER
3312* The number of process grids to be tested.
3313*
3314* CONTEXT0 (input) INTEGER array of dimension (NGRID)
3315* The BLACS context handles corresponding to the grids.
3316*
3317* P0 (input) INTEGER array of dimension (NGRID)
3318* Values of P (number of process rows, NPROW).
3319*
3320* Q0 (input) INTEGER array of dimension (NGRID)
3321* Values of Q (number of process columns, NPCOL).
3322*
3323* TFAIL (workspace) INTEGER array of dimension (NTESTS)
3324* If VERB < 2, serves to indicate which tests fail. This
3325* requires workspace of NTESTS (number of tests performed).
3326*
3327* MEM (workspace) COMPLEX array of dimension (MEMLEN)
3328* Used for all other workspaces, including the matrix A,
3329* and its pre and post padding.
3330*
3331* MEMLEN (input) INTEGER
3332* The length, in elements, of MEM.
3333*
3334* =====================================================================
3335*
3336* .. External Functions ..
3337 LOGICAL ALLPASS
3338 INTEGER IBTMYPROC, IBTSIZEOF
3339 EXTERNAL allpass, ibtmyproc, ibtsizeof
3340* ..
3341* .. External Subroutines ..
3342 EXTERNAL blacs_gridinfo
3343 EXTERNAL ctrsd2d, cgesd2d, ctrrv2d, cgerv2d
3344 EXTERNAL cinitmat, cchkmat, cchkpad, cbtcheckin
3345* ..
3346* .. Local Scalars ..
3347 CHARACTER*1 UPLO, DIAG
3348 LOGICAL TESTOK
3349 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3350 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3351 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3352 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
3353 COMPLEX SCHECKVAL, RCHECKVAL
3354* ..
3355* .. Executable Statements ..
3356*
3357 scheckval = cmplx( -0.01, -0.01 )
3358 rcheckval = cmplx( -0.02, -0.02 )
3359*
3360 iam = ibtmyproc()
3361 isize = ibtsizeof('I')
3362 csize = ibtsizeof('C')
3363*
3364* Verify file parameters
3365*
3366 IF( iam .EQ. 0 ) THEN
3367 WRITE(outnum, *) ' '
3368 WRITE(outnum, *) ' '
3369 WRITE(outnum, 1000 )
3370 IF( verb .GT. 0 ) THEN
3371 WRITE(outnum,*) ' '
3372 WRITE(outnum, 2000) 'NSHAPE:', nshape
3373 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3374 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3375 WRITE(outnum, 2000) 'NMAT :', nmat
3376 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3377 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3378 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3379 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3380 WRITE(outnum, 2000) 'NSRC :', nsrc
3381 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3382 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3383 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3384 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3385 WRITE(outnum, 2000) 'NGRIDS:', ngrid
3386 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3387 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3388 WRITE(outnum, 2000) 'VERB :', verb
3389 WRITE(outnum,*) ' '
3390 END IF
3391 IF( verb .GT. 1 ) THEN
3392 WRITE(outnum,5000)
3393 WRITE(outnum,6000)
3394 END IF
3395 END IF
3396*
3397* Find biggest matrix, so we know where to stick error info
3398*
3399 i = 0
3400 DO 10 ima = 1, nmat
3401 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3402 IF( k .GT. i ) i = k
3403 10 CONTINUE
3404 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
3405 IF( maxerr .LT. 1 ) THEN
3406 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3407 CALL blacs_abort(-1, 1)
3408 END IF
3409 errdptr = i + 1
3410 erriptr = errdptr + maxerr
3411 nerr = 0
3412 testnum = 0
3413 nfail = 0
3414 nskip = 0
3415*
3416* Loop over grids of matrix
3417*
3418 DO 110 igr = 1, ngrid
3419*
3420 context = context0(igr)
3421 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3422*
3423 DO 80 ish = 1, nshape
3424 uplo = uplo0(ish)
3425 diag = diag0(ish)
3426*
3427 DO 70 ima = 1, nmat
3428 m = m0(ima)
3429 n = n0(ima)
3430 ldasrc = ldas0(ima)
3431 ldadst = ldad0(ima)
3432*
3433 DO 60 iso = 1, nsrc
3434 testnum = testnum + 1
3435 rsrc = rsrc0(iso)
3436 csrc = csrc0(iso)
3437 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3438 nskip = nskip + 1
3439 GOTO 60
3440 END IF
3441 rdest = rdest0(iso)
3442 cdest = cdest0(iso)
3443 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3444 nskip = nskip + 1
3445 GOTO 60
3446 END IF
3447*
3448 IF( verb .GT. 1 ) THEN
3449 IF( iam .EQ. 0 ) THEN
3450 WRITE(outnum, 7000) testnum, 'RUNNING',
3451 $ uplo, diag, m, n,
3452 $ ldasrc, ldadst, rsrc, csrc,
3453 $ rdest, cdest, nprow, npcol
3454 END IF
3455 END IF
3456*
3457 testok = .true.
3458 ipre = 2 * m
3459 ipost = ipre
3460 aptr = ipre + 1
3461*
3462* source process generates matrix and sends it
3463*
3464 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3465 CALL cinitmat( uplo, diag, m, n, mem, ldasrc,
3466 $ ipre, ipost, scheckval, testnum,
3467 $ myrow, mycol )
3468*
3469 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3470 CALL ctrsd2d( context, uplo, diag, m, n,
3471 $ mem(aptr), ldasrc, rdest, cdest )
3472 ELSE
3473 CALL cgesd2d( context, m, n, mem(aptr),
3474 $ ldasrc, rdest, cdest )
3475 END IF
3476 END IF
3477*
3478 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3479*
3480* Pad entire matrix area
3481*
3482 DO 50 k = 1, ipre+ipost+ldadst*n
3483 mem(k) = rcheckval
3484 50 CONTINUE
3485*
3486* Receive matrix
3487*
3488 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3489 CALL ctrrv2d( context, uplo, diag, m, n,
3490 $ mem(aptr), ldadst, rsrc, csrc )
3491 ELSE
3492 CALL cgerv2d( context, m, n, mem(aptr),
3493 $ ldadst, rsrc, csrc )
3494 END IF
3495*
3496* Check for errors in matrix or padding
3497*
3498 i = nerr
3499 CALL cchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3500 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3501 $ nerr, mem(erriptr), mem(errdptr) )
3502*
3503 CALL cchkpad( uplo, diag, m, n, mem, ldadst,
3504 $ rsrc, csrc, myrow, mycol, ipre, ipost,
3505 $ rcheckval, testnum, maxerr, nerr,
3506 $ mem(erriptr), mem(errdptr) )
3507 testok = i .EQ. nerr
3508 END IF
3509*
3510 IF( verb .GT. 1 ) THEN
3511 i = nerr
3512 CALL cbtcheckin( 0, outnum, maxerr, nerr,
3513 $ mem(erriptr), mem(errdptr),
3514 $ tfail )
3515 IF( iam .EQ. 0 ) THEN
3516 IF( testok .AND. i.EQ.nerr ) THEN
3517 WRITE(outnum, 7000) testnum, 'PASSED ',
3518 $ uplo, diag, m, n, ldasrc, ldadst,
3519 $ rsrc, csrc, rdest, cdest, nprow, npcol
3520 ELSE
3521 nfail = nfail + 1
3522 WRITE(outnum, 7000) testnum, 'FAILED ',
3523 $ uplo, diag, m, n, ldasrc, ldadst,
3524 $ rsrc, csrc, rdest, cdest, nprow, npcol
3525 ENDIF
3526 END IF
3527*
3528* Once we've printed out errors, can re-use buf space
3529*
3530 nerr = 0
3531 END IF
3532 60 CONTINUE
3533 70 CONTINUE
3534 80 CONTINUE
3535 110 CONTINUE
3536*
3537 IF( verb .LT. 2 ) THEN
3538 nfail = testnum
3539 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3540 $ mem(errdptr), tfail )
3541 END IF
3542 IF( iam .EQ. 0 ) THEN
3543 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3544 IF( nfail+nskip .EQ. 0 ) THEN
3545 WRITE(outnum, 8000 ) testnum
3546 ELSE
3547 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3548 $ nskip, nfail
3549 END IF
3550 END IF
3551*
3552* Log whether their were any failures
3553*
3554 testok = allpass( (nfail.EQ.0) )
3555*
3556 1000 FORMAT('COMPLEX SDRV TESTS: BEGIN.' )
3557 2000 FORMAT(1x,a7,3x,10i6)
3558 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3559 $ 5x,a1,5x,a1)
3560 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3561 $ 'CSRC RDEST CDEST P Q')
3562 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3563 $ '---- ----- ----- ---- ----')
3564 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3565 8000 FORMAT('COMPLEX SDRV TESTS: PASSED ALL',
3566 $ i5, ' TESTS.')
3567 9000 FORMAT('COMPLEX SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3568 $ i5,' SKIPPED,',i5,' FAILED.')
3569*
3570 RETURN
3571*
3572* End of CSDRVTEST.
3573*
cmplx
float cmplx[2]
Definition pblas.h:136
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
cchkmat
subroutine cchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:10133
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: