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

◆ dsdrvtest()

subroutine dsdrvtest ( 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,
double precision, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 2889 of file blacstest.f.

2893*
2894* -- BLACS tester (version 1.0) --
2895* University of Tennessee
2896* December 15, 1994
2897*
2898*
2899* .. Scalar Arguments ..
2900 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2901* ..
2902* .. Array Arguments ..
2903 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2904 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2905 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2906 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2907 DOUBLE PRECISION MEM(MEMLEN)
2908* ..
2909*
2910* Purpose
2911* =======
2912* DTESTSDRV: Test double precision send/recv
2913*
2914* Arguments
2915* =========
2916* OUTNUM (input) INTEGER
2917* The device number to write output to.
2918*
2919* VERB (input) INTEGER
2920* The level of verbosity (how much printing to do).
2921*
2922* NSHAPE (input) INTEGER
2923* The number of matrix shapes to be tested.
2924*
2925* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2926* Values of UPLO to be tested.
2927*
2928* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2929* Values of DIAG to be tested.
2930*
2931* NMAT (input) INTEGER
2932* The number of matrices to be tested.
2933*
2934* M0 (input) INTEGER array of dimension (NMAT)
2935* Values of M to be tested.
2936*
2937* M0 (input) INTEGER array of dimension (NMAT)
2938* Values of M to be tested.
2939*
2940* N0 (input) INTEGER array of dimension (NMAT)
2941* Values of N to be tested.
2942*
2943* LDAS0 (input) INTEGER array of dimension (NMAT)
2944* Values of LDAS (leading dimension of A on source process)
2945* to be tested.
2946*
2947* LDAD0 (input) INTEGER array of dimension (NMAT)
2948* Values of LDAD (leading dimension of A on destination
2949* process) to be tested.
2950* NSRC (input) INTEGER
2951* The number of sources to be tested.
2952*
2953* RSRC0 (input) INTEGER array of dimension (NDEST)
2954* Values of RSRC (row coordinate of source) to be tested.
2955*
2956* CSRC0 (input) INTEGER array of dimension (NDEST)
2957* Values of CSRC (column coordinate of source) to be tested.
2958*
2959* RDEST0 (input) INTEGER array of dimension (NNSRC)
2960* Values of RDEST (row coordinate of destination) to be
2961* tested.
2962*
2963* CDEST0 (input) INTEGER array of dimension (NNSRC)
2964* Values of CDEST (column coordinate of destination) to be
2965* tested.
2966*
2967* NGRID (input) INTEGER
2968* The number of process grids to be tested.
2969*
2970* CONTEXT0 (input) INTEGER array of dimension (NGRID)
2971* The BLACS context handles corresponding to the grids.
2972*
2973* P0 (input) INTEGER array of dimension (NGRID)
2974* Values of P (number of process rows, NPROW).
2975*
2976* Q0 (input) INTEGER array of dimension (NGRID)
2977* Values of Q (number of process columns, NPCOL).
2978*
2979* TFAIL (workspace) INTEGER array of dimension (NTESTS)
2980* If VERB < 2, serves to indicate which tests fail. This
2981* requires workspace of NTESTS (number of tests performed).
2982*
2983* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
2984* Used for all other workspaces, including the matrix A,
2985* and its pre and post padding.
2986*
2987* MEMLEN (input) INTEGER
2988* The length, in elements, of MEM.
2989*
2990* =====================================================================
2991*
2992* .. External Functions ..
2993 LOGICAL ALLPASS
2994 INTEGER IBTMYPROC, IBTSIZEOF
2995 EXTERNAL allpass, ibtmyproc, ibtsizeof
2996* ..
2997* .. External Subroutines ..
2998 EXTERNAL blacs_gridinfo
2999 EXTERNAL dtrsd2d, dgesd2d, dtrrv2d, dgerv2d
3000 EXTERNAL dinitmat, dchkmat, dchkpad, dbtcheckin
3001* ..
3002* .. Local Scalars ..
3003 CHARACTER*1 UPLO, DIAG
3004 LOGICAL TESTOK
3005 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3006 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3007 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3008 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
3009 DOUBLE PRECISION SCHECKVAL, RCHECKVAL
3010* ..
3011* .. Executable Statements ..
3012*
3013 scheckval = -0.01d0
3014 rcheckval = -0.02d0
3015*
3016 iam = ibtmyproc()
3017 isize = ibtsizeof('I')
3018 dsize = ibtsizeof('D')
3019*
3020* Verify file parameters
3021*
3022 IF( iam .EQ. 0 ) THEN
3023 WRITE(outnum, *) ' '
3024 WRITE(outnum, *) ' '
3025 WRITE(outnum, 1000 )
3026 IF( verb .GT. 0 ) THEN
3027 WRITE(outnum,*) ' '
3028 WRITE(outnum, 2000) 'NSHAPE:', nshape
3029 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3030 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3031 WRITE(outnum, 2000) 'NMAT :', nmat
3032 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3033 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3034 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3035 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3036 WRITE(outnum, 2000) 'NSRC :', nsrc
3037 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3038 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3039 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3040 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3041 WRITE(outnum, 2000) 'NGRIDS:', ngrid
3042 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3043 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3044 WRITE(outnum, 2000) 'VERB :', verb
3045 WRITE(outnum,*) ' '
3046 END IF
3047 IF( verb .GT. 1 ) THEN
3048 WRITE(outnum,5000)
3049 WRITE(outnum,6000)
3050 END IF
3051 END IF
3052*
3053* Find biggest matrix, so we know where to stick error info
3054*
3055 i = 0
3056 DO 10 ima = 1, nmat
3057 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3058 IF( k .GT. i ) i = k
3059 10 CONTINUE
3060 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
3061 IF( maxerr .LT. 1 ) THEN
3062 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3063 CALL blacs_abort(-1, 1)
3064 END IF
3065 errdptr = i + 1
3066 erriptr = errdptr + maxerr
3067 nerr = 0
3068 testnum = 0
3069 nfail = 0
3070 nskip = 0
3071*
3072* Loop over grids of matrix
3073*
3074 DO 110 igr = 1, ngrid
3075*
3076 context = context0(igr)
3077 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3078*
3079 DO 80 ish = 1, nshape
3080 uplo = uplo0(ish)
3081 diag = diag0(ish)
3082*
3083 DO 70 ima = 1, nmat
3084 m = m0(ima)
3085 n = n0(ima)
3086 ldasrc = ldas0(ima)
3087 ldadst = ldad0(ima)
3088*
3089 DO 60 iso = 1, nsrc
3090 testnum = testnum + 1
3091 rsrc = rsrc0(iso)
3092 csrc = csrc0(iso)
3093 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3094 nskip = nskip + 1
3095 GOTO 60
3096 END IF
3097 rdest = rdest0(iso)
3098 cdest = cdest0(iso)
3099 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3100 nskip = nskip + 1
3101 GOTO 60
3102 END IF
3103*
3104 IF( verb .GT. 1 ) THEN
3105 IF( iam .EQ. 0 ) THEN
3106 WRITE(outnum, 7000) testnum, 'RUNNING',
3107 $ uplo, diag, m, n,
3108 $ ldasrc, ldadst, rsrc, csrc,
3109 $ rdest, cdest, nprow, npcol
3110 END IF
3111 END IF
3112*
3113 testok = .true.
3114 ipre = 2 * m
3115 ipost = ipre
3116 aptr = ipre + 1
3117*
3118* source process generates matrix and sends it
3119*
3120 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3121 CALL dinitmat( uplo, diag, m, n, mem, ldasrc,
3122 $ ipre, ipost, scheckval, testnum,
3123 $ myrow, mycol )
3124*
3125 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3126 CALL dtrsd2d( context, uplo, diag, m, n,
3127 $ mem(aptr), ldasrc, rdest, cdest )
3128 ELSE
3129 CALL dgesd2d( context, m, n, mem(aptr),
3130 $ ldasrc, rdest, cdest )
3131 END IF
3132 END IF
3133*
3134 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3135*
3136* Pad entire matrix area
3137*
3138 DO 50 k = 1, ipre+ipost+ldadst*n
3139 mem(k) = rcheckval
3140 50 CONTINUE
3141*
3142* Receive matrix
3143*
3144 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3145 CALL dtrrv2d( context, uplo, diag, m, n,
3146 $ mem(aptr), ldadst, rsrc, csrc )
3147 ELSE
3148 CALL dgerv2d( context, m, n, mem(aptr),
3149 $ ldadst, rsrc, csrc )
3150 END IF
3151*
3152* Check for errors in matrix or padding
3153*
3154 i = nerr
3155 CALL dchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3156 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3157 $ nerr, mem(erriptr), mem(errdptr) )
3158*
3159 CALL dchkpad( uplo, diag, m, n, mem, ldadst,
3160 $ rsrc, csrc, myrow, mycol, ipre, ipost,
3161 $ rcheckval, testnum, maxerr, nerr,
3162 $ mem(erriptr), mem(errdptr) )
3163 testok = i .EQ. nerr
3164 END IF
3165*
3166 IF( verb .GT. 1 ) THEN
3167 i = nerr
3168 CALL dbtcheckin( 0, outnum, maxerr, nerr,
3169 $ mem(erriptr), mem(errdptr),
3170 $ tfail )
3171 IF( iam .EQ. 0 ) THEN
3172 IF( testok .AND. i.EQ.nerr ) THEN
3173 WRITE(outnum, 7000) testnum, 'PASSED ',
3174 $ uplo, diag, m, n, ldasrc, ldadst,
3175 $ rsrc, csrc, rdest, cdest, nprow, npcol
3176 ELSE
3177 nfail = nfail + 1
3178 WRITE(outnum, 7000) testnum, 'FAILED ',
3179 $ uplo, diag, m, n, ldasrc, ldadst,
3180 $ rsrc, csrc, rdest, cdest, nprow, npcol
3181 ENDIF
3182 END IF
3183*
3184* Once we've printed out errors, can re-use buf space
3185*
3186 nerr = 0
3187 END IF
3188 60 CONTINUE
3189 70 CONTINUE
3190 80 CONTINUE
3191 110 CONTINUE
3192*
3193 IF( verb .LT. 2 ) THEN
3194 nfail = testnum
3195 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3196 $ mem(errdptr), tfail )
3197 END IF
3198 IF( iam .EQ. 0 ) THEN
3199 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3200 IF( nfail+nskip .EQ. 0 ) THEN
3201 WRITE(outnum, 8000 ) testnum
3202 ELSE
3203 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3204 $ nskip, nfail
3205 END IF
3206 END IF
3207*
3208* Log whether their were any failures
3209*
3210 testok = allpass( (nfail.EQ.0) )
3211*
3212 1000 FORMAT('DOUBLE PRECISION SDRV TESTS: BEGIN.' )
3213 2000 FORMAT(1x,a7,3x,10i6)
3214 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3215 $ 5x,a1,5x,a1)
3216 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3217 $ 'CSRC RDEST CDEST P Q')
3218 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3219 $ '---- ----- ----- ---- ----')
3220 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3221 8000 FORMAT('DOUBLE PRECISION SDRV TESTS: PASSED ALL',
3222 $ i5, ' TESTS.')
3223 9000 FORMAT('DOUBLE PRECISION SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3224 $ i5,' SKIPPED,',i5,' FAILED.')
3225*
3226 RETURN
3227*
3228* End of DSDRVTEST.
3229*
dchkmat
subroutine dchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:9071
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
dchkpad
subroutine dchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:8810
dinitmat
subroutine dinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:8527
dbtcheckin
subroutine dbtcheckin(nftests, outnum, maxerr, nerr, ierr, dval, tfailed)
Definition blacstest.f:8405
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: