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

◆ pcblas3tstchk()

subroutine pcblas3tstchk ( integer  ictxt,
integer  nout,
integer  nrout,
character*1  side,
character*1  uplo,
character*1  transa,
character*1  transb,
character*1  diag,
integer  m,
integer  n,
integer  k,
complex  alpha,
complex, dimension( * )  a,
complex, dimension( * )  pa,
integer  ia,
integer  ja,
integer, dimension( * )  desca,
complex, dimension( * )  b,
complex, dimension( * )  pb,
integer  ib,
integer  jb,
integer, dimension( * )  descb,
complex  beta,
complex, dimension( * )  c,
complex, dimension( * )  pc,
integer  ic,
integer  jc,
integer, dimension( * )  descc,
real  thresh,
complex  rogue,
complex, dimension( * )  work,
real, dimension( * )  rwork,
integer  info 
)

Definition at line 2865 of file pcblas3tst.f.

2870*
2871* -- PBLAS test routine (version 2.0) --
2872* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2873* and University of California, Berkeley.
2874* April 1, 1998
2875*
2876* .. Scalar Arguments ..
2877 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2878 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2879 $ NOUT, NROUT
2880 REAL THRESH
2881 COMPLEX ALPHA, BETA, ROGUE
2882* ..
2883* .. Array Arguments ..
2884 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2885 REAL RWORK( * )
2886 COMPLEX A( * ), B( * ), C( * ), PA( * ), PB( * ),
2887 $ PC( * ), WORK( * )
2888* ..
2889*
2890* Purpose
2891* =======
2892*
2893* PCBLAS3TSTCHK performs the computational tests of the Level 3 PBLAS.
2894*
2895* Notes
2896* =====
2897*
2898* A description vector is associated with each 2D block-cyclicly dis-
2899* tributed matrix. This vector stores the information required to
2900* establish the mapping between a matrix entry and its corresponding
2901* process and memory location.
2902*
2903* In the following comments, the character _ should be read as
2904* "of the distributed matrix". Let A be a generic term for any 2D
2905* block cyclicly distributed matrix. Its description vector is DESCA:
2906*
2907* NOTATION STORED IN EXPLANATION
2908* ---------------- --------------- ------------------------------------
2909* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2910* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2911* the NPROW x NPCOL BLACS process grid
2912* A is distributed over. The context
2913* itself is global, but the handle
2914* (the integer value) may vary.
2915* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2916* ted matrix A, M_A >= 0.
2917* N_A (global) DESCA( N_ ) The number of columns in the distri-
2918* buted matrix A, N_A >= 0.
2919* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2920* block of the matrix A, IMB_A > 0.
2921* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2922* left block of the matrix A,
2923* INB_A > 0.
2924* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2925* bute the last M_A-IMB_A rows of A,
2926* MB_A > 0.
2927* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2928* bute the last N_A-INB_A columns of
2929* A, NB_A > 0.
2930* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2931* row of the matrix A is distributed,
2932* NPROW > RSRC_A >= 0.
2933* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2934* first column of A is distributed.
2935* NPCOL > CSRC_A >= 0.
2936* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2937* array storing the local blocks of
2938* the distributed matrix A,
2939* IF( Lc( 1, N_A ) > 0 )
2940* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2941* ELSE
2942* LLD_A >= 1.
2943*
2944* Let K be the number of rows of a matrix A starting at the global in-
2945* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2946* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2947* receive if these K rows were distributed over NPROW processes. If K
2948* is the number of columns of a matrix A starting at the global index
2949* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2950* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2951* these K columns were distributed over NPCOL processes.
2952*
2953* The values of Lr() and Lc() may be determined via a call to the func-
2954* tion PB_NUMROC:
2955* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2956* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2957*
2958* Arguments
2959* =========
2960*
2961* ICTXT (local input) INTEGER
2962* On entry, ICTXT specifies the BLACS context handle, indica-
2963* ting the global context of the operation. The context itself
2964* is global, but the value of ICTXT is local.
2965*
2966* NOUT (global input) INTEGER
2967* On entry, NOUT specifies the unit number for the output file.
2968* When NOUT is 6, output to screen, when NOUT is 0, output to
2969* stderr. NOUT is only defined for process 0.
2970*
2971* NROUT (global input) INTEGER
2972* On entry, NROUT specifies which routine will be tested as
2973* follows:
2974* If NROUT = 1, PCGEMM will be tested;
2975* else if NROUT = 2, PCSYMM will be tested;
2976* else if NROUT = 3, PCHEMM will be tested;
2977* else if NROUT = 4, PCSYRK will be tested;
2978* else if NROUT = 5, PCHERK will be tested;
2979* else if NROUT = 6, PCSYR2K will be tested;
2980* else if NROUT = 7, PCHER2K will be tested;
2981* else if NROUT = 8, PCTRMM will be tested;
2982* else if NROUT = 9, PCTRSM will be tested;
2983* else if NROUT = 10, PCGEADD will be tested;
2984* else if NROUT = 11, PCTRADD will be tested;
2985*
2986* SIDE (global input) CHARACTER*1
2987* On entry, SIDE specifies if the multiplication should be per-
2988* formed from the left or the right.
2989*
2990* UPLO (global input) CHARACTER*1
2991* On entry, UPLO specifies if the upper or lower part of the
2992* matrix operand is to be referenced.
2993*
2994* TRANSA (global input) CHARACTER*1
2995* On entry, TRANSA specifies if the matrix operand A is to be
2996* transposed.
2997*
2998* TRANSB (global input) CHARACTER*1
2999* On entry, TRANSB specifies if the matrix operand B is to be
3000* transposed.
3001*
3002* DIAG (global input) CHARACTER*1
3003* On entry, DIAG specifies if the triangular matrix operand is
3004* unit or non-unit.
3005*
3006* M (global input) INTEGER
3007* On entry, M specifies the number of rows of C.
3008*
3009* N (global input) INTEGER
3010* On entry, N specifies the number of columns of C.
3011*
3012* K (global input) INTEGER
3013* On entry, K specifies the number of columns (resp. rows) of A
3014* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
3015* PxSYR2K, PxHERK and PxHER2K.
3016*
3017* ALPHA (global input) COMPLEX
3018* On entry, ALPHA specifies the scalar alpha.
3019*
3020* A (local input/local output) COMPLEX array
3021* On entry, A is an array of dimension (DESCA( M_ ),*). This
3022* array contains a local copy of the initial entire matrix PA.
3023*
3024* PA (local input) COMPLEX array
3025* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3026* array contains the local entries of the matrix PA.
3027*
3028* IA (global input) INTEGER
3029* On entry, IA specifies A's global row index, which points to
3030* the beginning of the submatrix sub( A ).
3031*
3032* JA (global input) INTEGER
3033* On entry, JA specifies A's global column index, which points
3034* to the beginning of the submatrix sub( A ).
3035*
3036* DESCA (global and local input) INTEGER array
3037* On entry, DESCA is an integer array of dimension DLEN_. This
3038* is the array descriptor for the matrix A.
3039*
3040* B (local input/local output) COMPLEX array
3041* On entry, B is an array of dimension (DESCB( M_ ),*). This
3042* array contains a local copy of the initial entire matrix PB.
3043*
3044* PB (local input) COMPLEX array
3045* On entry, PB is an array of dimension (DESCB( LLD_ ),*). This
3046* array contains the local entries of the matrix PB.
3047*
3048* IB (global input) INTEGER
3049* On entry, IB specifies B's global row index, which points to
3050* the beginning of the submatrix sub( B ).
3051*
3052* JB (global input) INTEGER
3053* On entry, JB specifies B's global column index, which points
3054* to the beginning of the submatrix sub( B ).
3055*
3056* DESCB (global and local input) INTEGER array
3057* On entry, DESCB is an integer array of dimension DLEN_. This
3058* is the array descriptor for the matrix B.
3059*
3060* BETA (global input) COMPLEX
3061* On entry, BETA specifies the scalar beta.
3062*
3063* C (local input/local output) COMPLEX array
3064* On entry, C is an array of dimension (DESCC( M_ ),*). This
3065* array contains a local copy of the initial entire matrix PC.
3066*
3067* PC (local input) COMPLEX array
3068* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
3069* array contains the local pieces of the matrix PC.
3070*
3071* IC (global input) INTEGER
3072* On entry, IC specifies C's global row index, which points to
3073* the beginning of the submatrix sub( C ).
3074*
3075* JC (global input) INTEGER
3076* On entry, JC specifies C's global column index, which points
3077* to the beginning of the submatrix sub( C ).
3078*
3079* DESCC (global and local input) INTEGER array
3080* On entry, DESCC is an integer array of dimension DLEN_. This
3081* is the array descriptor for the matrix C.
3082*
3083* THRESH (global input) REAL
3084* On entry, THRESH is the threshold value for the test ratio.
3085*
3086* ROGUE (global input) COMPLEX
3087* On entry, ROGUE specifies the constant used to pad the
3088* non-referenced part of triangular, symmetric or Hermitian ma-
3089* trices.
3090*
3091* WORK (workspace) COMPLEX array
3092* On entry, WORK is an array of dimension LWORK where LWORK is
3093* at least MAX( M, MAX( N, K ) ). This array is used to store
3094* a copy of a column of C (see PCMMCH).
3095*
3096* RWORK (workspace) REAL array
3097* On entry, RWORK is an array of dimension LRWORK where LRWORK
3098* is at least MAX( M, MAX( N, K ) ). This array is used to sto-
3099* re the computed gauges (see PCMMCH).
3100*
3101* INFO (global output) INTEGER
3102* On exit, if INFO = 0, no error has been found, otherwise
3103* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
3104* if( MOD( INFO/2, 2 ) = 1 ) then an error on B has been found,
3105* if( MOD( INFO/4, 2 ) = 1 ) then an error on C has been found.
3106*
3107* -- Written on April 1, 1998 by
3108* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3109*
3110* =====================================================================
3111*
3112* .. Parameters ..
3113 REAL RZERO
3114 parameter( rzero = 0.0e+0 )
3115 COMPLEX ONE, ZERO
3116 parameter( one = ( 1.0e+0, 0.0e+0 ),
3117 $ zero = ( 0.0e+0, 0.0e+0 ) )
3118 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3119 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3120 $ RSRC_
3121 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3122 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3123 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3124 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3125* ..
3126* .. Local Scalars ..
3127 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
3128 REAL ERR
3129 COMPLEX ALPHA1, BETA1
3130* ..
3131* .. Local Arrays ..
3132 INTEGER IERR( 3 )
3133* ..
3134* .. External Subroutines ..
3135 EXTERNAL blacs_gridinfo, ctrsm, pb_claset, pcchkmin,
3136 $ pcmmch, pcmmch1, pcmmch2, pcmmch3, pctrmm
3137* ..
3138* .. External Functions ..
3139 LOGICAL LSAME
3140 EXTERNAL lsame
3141* ..
3142* .. Intrinsic Functions ..
3143 INTRINSIC cmplx, real
3144* ..
3145* .. Executable Statements ..
3146*
3147 info = 0
3148*
3149* Quick return if possible
3150*
3151 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
3152 $ RETURN
3153*
3154* Start the operations
3155*
3156 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3157*
3158 DO 10 i = 1, 3
3159 ierr( i ) = 0
3160 10 CONTINUE
3161*
3162 IF( nrout.EQ.1 ) THEN
3163*
3164* Test PCGEMM
3165*
3166* Check the resulting matrix C
3167*
3168 CALL pcmmch( ictxt, transa, transb, m, n, k, alpha, a, ia, ja,
3169 $ desca, b, ib, jb, descb, beta, c, pc, ic, jc,
3170 $ descc, work, rwork, err, ierr( 3 ) )
3171*
3172 IF( ierr( 3 ).NE.0 ) THEN
3173 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3174 $ WRITE( nout, fmt = 9998 )
3175 ELSE IF( err.GT.thresh ) THEN
3176 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3177 $ WRITE( nout, fmt = 9997 ) err
3178 END IF
3179*
3180* Check the input-only arguments
3181*
3182 IF( lsame( transa, 'N' ) ) THEN
3183 CALL pcchkmin( err, m, k, a, pa, ia, ja, desca, ierr( 1 ) )
3184 ELSE
3185 CALL pcchkmin( err, k, m, a, pa, ia, ja, desca, ierr( 1 ) )
3186 END IF
3187 IF( lsame( transb, 'N' ) ) THEN
3188 CALL pcchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3189 ELSE
3190 CALL pcchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3191 END IF
3192*
3193 ELSE IF( nrout.EQ.2 ) THEN
3194*
3195* Test PCSYMM
3196*
3197* Check the resulting matrix C
3198*
3199 IF( lsame( side, 'L' ) ) THEN
3200 CALL pcmmch( ictxt, 'No transpose', 'No transpose', m, n, m,
3201 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3202 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3203 $ ierr( 3 ) )
3204 ELSE
3205 CALL pcmmch( ictxt, 'No transpose', 'No transpose', m, n, n,
3206 $ alpha, b, ib, jb, descb, a, ia, ja, desca,
3207 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3208 $ ierr( 3 ) )
3209 END IF
3210*
3211 IF( ierr( 3 ).NE.0 ) THEN
3212 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3213 $ WRITE( nout, fmt = 9998 )
3214 ELSE IF( err.GT.thresh ) THEN
3215 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3216 $ WRITE( nout, fmt = 9997 ) err
3217 END IF
3218*
3219* Check the input-only arguments
3220*
3221 IF( lsame( uplo, 'L' ) ) THEN
3222 IF( lsame( side, 'L' ) ) THEN
3223 CALL pb_claset( 'Upper', m-1, m-1, 0, rogue, rogue,
3224 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3225 ELSE
3226 CALL pb_claset( 'Upper', n-1, n-1, 0, rogue, rogue,
3227 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3228 END IF
3229 ELSE
3230 IF( lsame( side, 'L' ) ) THEN
3231 CALL pb_claset( 'Lower', m-1, m-1, 0, rogue, rogue,
3232 $ a( ia+1+(ja-1)*desca( m_ ) ),
3233 $ desca( m_ ) )
3234 ELSE
3235 CALL pb_claset( 'Lower', n-1, n-1, 0, rogue, rogue,
3236 $ a( ia+1+(ja-1)*desca( m_ ) ),
3237 $ desca( m_ ) )
3238 END IF
3239 END IF
3240*
3241 IF( lsame( side, 'L' ) ) THEN
3242 CALL pcchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3243 ELSE
3244 CALL pcchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3245 END IF
3246 CALL pcchkmin( err, m, n, b, pb, ib, jb, descb, ierr( 2 ) )
3247*
3248 ELSE IF( nrout.EQ.3 ) THEN
3249*
3250* Test PCHEMM
3251*
3252* Check the resulting matrix C
3253*
3254 IF( lsame( side, 'L' ) ) THEN
3255 CALL pcmmch( ictxt, 'No transpose', 'No transpose', m, n, m,
3256 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3257 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3258 $ ierr( 3 ) )
3259 ELSE
3260 CALL pcmmch( ictxt, 'No transpose', 'No transpose', m, n, n,
3261 $ alpha, b, ib, jb, descb, a, ia, ja, desca,
3262 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3263 $ ierr( 3 ) )
3264 END IF
3265*
3266 IF( ierr( 3 ).NE.0 ) THEN
3267 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3268 $ WRITE( nout, fmt = 9998 )
3269 ELSE IF( err.GT.thresh ) THEN
3270 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3271 $ WRITE( nout, fmt = 9997 ) err
3272 END IF
3273*
3274* Check the input-only arguments
3275*
3276 IF( lsame( uplo, 'L' ) ) THEN
3277 IF( lsame( side, 'L' ) ) THEN
3278 CALL pb_claset( 'Upper', m-1, m-1, 0, rogue, rogue,
3279 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3280 ELSE
3281 CALL pb_claset( 'Upper', n-1, n-1, 0, rogue, rogue,
3282 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3283 END IF
3284 ELSE
3285 IF( lsame( side, 'L' ) ) THEN
3286 CALL pb_claset( 'Lower', m-1, m-1, 0, rogue, rogue,
3287 $ a( ia+1+(ja-1)*desca( m_ ) ),
3288 $ desca( m_ ) )
3289 ELSE
3290 CALL pb_claset( 'Lower', n-1, n-1, 0, rogue, rogue,
3291 $ a( ia+1+(ja-1)*desca( m_ ) ),
3292 $ desca( m_ ) )
3293 END IF
3294 END IF
3295*
3296 IF( lsame( side, 'L' ) ) THEN
3297 CALL pcchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3298 ELSE
3299 CALL pcchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3300 END IF
3301 CALL pcchkmin( err, m, n, b, pb, ib, jb, descb, ierr( 2 ) )
3302*
3303 ELSE IF( nrout.EQ.4 ) THEN
3304*
3305* Test PCSYRK
3306*
3307* Check the resulting matrix C
3308*
3309 IF( lsame( transa, 'N' ) ) THEN
3310 CALL pcmmch1( ictxt, uplo, 'No transpose', n, k, alpha, a,
3311 $ ia, ja, desca, beta, c, pc, ic, jc, descc,
3312 $ work, rwork, err, ierr( 3 ) )
3313 ELSE
3314 CALL pcmmch1( ictxt, uplo, 'Transpose', n, k, alpha, a, ia,
3315 $ ja, desca, beta, c, pc, ic, jc, descc, work,
3316 $ rwork, err, ierr( 3 ) )
3317 END IF
3318*
3319 IF( ierr( 3 ).NE.0 ) THEN
3320 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3321 $ WRITE( nout, fmt = 9998 )
3322 ELSE IF( err.GT.thresh ) THEN
3323 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3324 $ WRITE( nout, fmt = 9997 ) err
3325 END IF
3326*
3327* Check the input-only arguments
3328*
3329 IF( lsame( transa, 'N' ) ) THEN
3330 CALL pcchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3331 ELSE
3332 CALL pcchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3333 END IF
3334*
3335 ELSE IF( nrout.EQ.5 ) THEN
3336*
3337* Test PCHERK
3338*
3339* Check the resulting matrix C
3340*
3341 beta1 = cmplx( real( beta ), rzero )
3342 alpha1 = cmplx( real( alpha ), rzero )
3343 IF( lsame( transa, 'N' ) ) THEN
3344 CALL pcmmch1( ictxt, uplo, 'Hermitian', n, k, alpha1, a, ia,
3345 $ ja, desca, beta1, c, pc, ic, jc, descc, work,
3346 $ rwork, err, ierr( 3 ) )
3347 ELSE
3348 CALL pcmmch1( ictxt, uplo, 'Conjugate transpose', n, k,
3349 $ alpha1, a, ia, ja, desca, beta1, c, pc, ic,
3350 $ jc, descc, work, rwork, err, ierr( 3 ) )
3351 END IF
3352*
3353 IF( ierr( 3 ).NE.0 ) THEN
3354 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3355 $ WRITE( nout, fmt = 9998 )
3356 ELSE IF( err.GT.thresh ) THEN
3357 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3358 $ WRITE( nout, fmt = 9997 ) err
3359 END IF
3360*
3361* Check the input-only arguments
3362*
3363 IF( lsame( transa, 'N' ) ) THEN
3364 CALL pcchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3365 ELSE
3366 CALL pcchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3367 END IF
3368*
3369 ELSE IF( nrout.EQ.6 ) THEN
3370*
3371* Test PCSYR2K
3372*
3373* Check the resulting matrix C
3374*
3375 IF( lsame( transa, 'N' ) ) THEN
3376 CALL pcmmch2( ictxt, uplo, 'No transpose', n, k, alpha, a,
3377 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3378 $ ic, jc, descc, work, rwork, err, ierr( 3 ) )
3379 ELSE
3380 CALL pcmmch2( ictxt, uplo, 'Transpose', n, k, alpha, a,
3381 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3382 $ ic, jc, descc, work, rwork, err,
3383 $ ierr( 3 ) )
3384 END IF
3385*
3386 IF( ierr( 3 ).NE.0 ) THEN
3387 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3388 $ WRITE( nout, fmt = 9998 )
3389 ELSE IF( err.GT.thresh ) THEN
3390 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3391 $ WRITE( nout, fmt = 9997 ) err
3392 END IF
3393*
3394* Check the input-only arguments
3395*
3396 IF( lsame( transa, 'N' ) ) THEN
3397 CALL pcchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3398 CALL pcchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3399 ELSE
3400 CALL pcchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3401 CALL pcchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3402 END IF
3403*
3404 ELSE IF( nrout.EQ.7 ) THEN
3405*
3406* Test PCHER2K
3407*
3408* Check the resulting matrix C
3409*
3410 beta1 = cmplx( real( beta ), rzero )
3411 IF( lsame( transa, 'N' ) ) THEN
3412 CALL pcmmch2( ictxt, uplo, 'Hermitian', n, k, alpha, a, ia,
3413 $ ja, desca, b, ib, jb, descb, beta1, c, pc, ic,
3414 $ jc, descc, work, rwork, err, ierr( 3 ) )
3415 ELSE
3416 CALL pcmmch2( ictxt, uplo, 'Conjugate transpose', n, k,
3417 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3418 $ beta1, c, pc, ic, jc, descc, work, rwork, err,
3419 $ ierr( 3 ) )
3420 END IF
3421*
3422 IF( ierr( 3 ).NE.0 ) THEN
3423 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3424 $ WRITE( nout, fmt = 9998 )
3425 ELSE IF( err.GT.thresh ) THEN
3426 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3427 $ WRITE( nout, fmt = 9997 ) err
3428 END IF
3429*
3430* Check the input-only arguments
3431*
3432 IF( lsame( transa, 'N' ) ) THEN
3433 CALL pcchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3434 CALL pcchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3435 ELSE
3436 CALL pcchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3437 CALL pcchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3438 END IF
3439*
3440 ELSE IF( nrout.EQ.8 ) THEN
3441*
3442* Test PCTRMM
3443*
3444* Check the resulting matrix B
3445*
3446 IF( lsame( side, 'L' ) ) THEN
3447 CALL pcmmch( ictxt, transa, 'No transpose', m, n, m,
3448 $ alpha, a, ia, ja, desca, c, ib, jb, descb,
3449 $ zero, b, pb, ib, jb, descb, work, rwork, err,
3450 $ ierr( 2 ) )
3451 ELSE
3452 CALL pcmmch( ictxt, 'No transpose', transa, m, n, n,
3453 $ alpha, c, ib, jb, descb, a, ia, ja, desca,
3454 $ zero, b, pb, ib, jb, descb, work, rwork, err,
3455 $ ierr( 2 ) )
3456 END IF
3457*
3458 IF( ierr( 2 ).NE.0 ) THEN
3459 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3460 $ WRITE( nout, fmt = 9998 )
3461 ELSE IF( err.GT.thresh ) THEN
3462 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3463 $ WRITE( nout, fmt = 9997 ) err
3464 END IF
3465*
3466* Check the input-only arguments
3467*
3468 IF( lsame( side, 'L' ) ) THEN
3469 IF( lsame( uplo, 'L' ) ) THEN
3470 IF( lsame( diag, 'N' ) ) THEN
3471 CALL pb_claset( 'Upper', m-1, m-1, 0, rogue, rogue,
3472 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3473 ELSE
3474 CALL pb_claset( 'Upper', m, m, 0, rogue, one,
3475 $ a( ia+(ja-1)*desca( m_ ) ),
3476 $ desca( m_ ) )
3477 END IF
3478 ELSE
3479 IF( lsame( diag, 'N' ) ) THEN
3480 CALL pb_claset( 'Lower', m-1, m-1, 0, rogue, rogue,
3481 $ a( ia+1+(ja-1)*desca( m_ ) ),
3482 $ desca( m_ ) )
3483 ELSE
3484 CALL pb_claset( 'Lower', m, m, 0, rogue, one,
3485 $ a( ia+(ja-1)*desca( m_ ) ),
3486 $ desca( m_ ) )
3487 END IF
3488 END IF
3489 CALL pcchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3490 ELSE
3491 IF( lsame( uplo, 'L' ) ) THEN
3492 IF( lsame( diag, 'N' ) ) THEN
3493 CALL pb_claset( 'Upper', n-1, n-1, 0, rogue, rogue,
3494 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3495 ELSE
3496 CALL pb_claset( 'Upper', n, n, 0, rogue, one,
3497 $ a( ia+(ja-1)*desca( m_ ) ),
3498 $ desca( m_ ) )
3499 END IF
3500 ELSE
3501 IF( lsame( diag, 'N' ) ) THEN
3502 CALL pb_claset( 'Lower', n-1, n-1, 0, rogue, rogue,
3503 $ a( ia+1+(ja-1)*desca( m_ ) ),
3504 $ desca( m_ ) )
3505 ELSE
3506 CALL pb_claset( 'Lower', n, n, 0, rogue, one,
3507 $ a( ia+(ja-1)*desca( m_ ) ),
3508 $ desca( m_ ) )
3509 END IF
3510 END IF
3511 CALL pcchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3512 END IF
3513*
3514 ELSE IF( nrout.EQ.9 ) THEN
3515*
3516* Test PCTRSM
3517*
3518* Check the resulting matrix B
3519*
3520 CALL ctrsm( side, uplo, transa, diag, m, n, alpha,
3521 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ),
3522 $ b( ib+(jb-1)*descb( m_ ) ), descb( m_ ) )
3523 CALL pctrmm( side, uplo, transa, diag, m, n, alpha, pa, ia, ja,
3524 $ desca, pb, ib, jb, descb )
3525 IF( lsame( side, 'L' ) ) THEN
3526 CALL pcmmch( ictxt, transa, 'No transpose', m, n, m, alpha,
3527 $ a, ia, ja, desca, b, ib, jb, descb, zero, c,
3528 $ pb, ib, jb, descb, work, rwork, err,
3529 $ ierr( 2 ) )
3530 ELSE
3531 CALL pcmmch( ictxt, 'No transpose', transa, m, n, n, alpha,
3532 $ b, ib, jb, descb, a, ia, ja, desca, zero, c,
3533 $ pb, ib, jb, descb, work, rwork, err,
3534 $ ierr( 2 ) )
3535 END IF
3536*
3537 IF( ierr( 2 ).NE.0 ) THEN
3538 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3539 $ WRITE( nout, fmt = 9998 )
3540 ELSE IF( err.GT.thresh ) THEN
3541 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3542 $ WRITE( nout, fmt = 9997 ) err
3543 END IF
3544*
3545* Check the input-only arguments
3546*
3547 IF( lsame( side, 'L' ) ) THEN
3548 IF( lsame( uplo, 'L' ) ) THEN
3549 IF( lsame( diag, 'N' ) ) THEN
3550 CALL pb_claset( 'Upper', m-1, m-1, 0, rogue, rogue,
3551 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3552 ELSE
3553 CALL pb_claset( 'Upper', m, m, 0, rogue, one,
3554 $ a( ia+(ja-1)*desca( m_ ) ),
3555 $ desca( m_ ) )
3556 END IF
3557 ELSE
3558 IF( lsame( diag, 'N' ) ) THEN
3559 CALL pb_claset( 'Lower', m-1, m-1, 0, rogue, rogue,
3560 $ a( ia+1+(ja-1)*desca( m_ ) ),
3561 $ desca( m_ ) )
3562 ELSE
3563 CALL pb_claset( 'Lower', m, m, 0, rogue, one,
3564 $ a( ia+(ja-1)*desca( m_ ) ),
3565 $ desca( m_ ) )
3566 END IF
3567 END IF
3568 CALL pcchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3569 ELSE
3570 IF( lsame( uplo, 'L' ) ) THEN
3571 IF( lsame( diag, 'N' ) ) THEN
3572 CALL pb_claset( 'Upper', n-1, n-1, 0, rogue, rogue,
3573 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3574 ELSE
3575 CALL pb_claset( 'Upper', n, n, 0, rogue, one,
3576 $ a( ia+(ja-1)*desca( m_ ) ),
3577 $ desca( m_ ) )
3578 END IF
3579 ELSE
3580 IF( lsame( diag, 'N' ) ) THEN
3581 CALL pb_claset( 'Lower', n-1, n-1, 0, rogue, rogue,
3582 $ a( ia+1+(ja-1)*desca( m_ ) ),
3583 $ desca( m_ ) )
3584 ELSE
3585 CALL pb_claset( 'Lower', n, n, 0, rogue, one,
3586 $ a( ia+(ja-1)*desca( m_ ) ),
3587 $ desca( m_ ) )
3588 END IF
3589 END IF
3590 CALL pcchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3591 END IF
3592 ELSE IF( nrout.EQ.10 ) THEN
3593*
3594* Test PCGEADD
3595*
3596* Check the resulting matrix C
3597*
3598 CALL pcmmch3( 'All', transa, m, n, alpha, a, ia, ja, desca,
3599 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3600*
3601* Check the input-only arguments
3602*
3603 IF( lsame( transa, 'N' ) ) THEN
3604 CALL pcchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3605 ELSE
3606 CALL pcchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3607 END IF
3608*
3609 ELSE IF( nrout.EQ.11 ) THEN
3610*
3611* Test PCTRADD
3612*
3613* Check the resulting matrix C
3614*
3615 CALL pcmmch3( uplo, transa, m, n, alpha, a, ia, ja, desca,
3616 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3617*
3618* Check the input-only arguments
3619*
3620 IF( lsame( transa, 'N' ) ) THEN
3621 CALL pcchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3622 ELSE
3623 CALL pcchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3624 END IF
3625*
3626 END IF
3627*
3628 IF( ierr( 1 ).NE.0 ) THEN
3629 info = info + 1
3630 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3631 $ WRITE( nout, fmt = 9999 ) 'A'
3632 END IF
3633*
3634 IF( ierr( 2 ).NE.0 ) THEN
3635 info = info + 2
3636 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3637 $ WRITE( nout, fmt = 9999 ) 'B'
3638 END IF
3639*
3640 IF( ierr( 3 ).NE.0 ) THEN
3641 info = info + 4
3642 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3643 $ WRITE( nout, fmt = 9999 ) 'C'
3644 END IF
3645*
3646 9999 FORMAT( 2x, ' ***** ERROR: Matrix operand ', a,
3647 $ ' is incorrect.' )
3648 9998 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3649 $ 'than half accurate *****' )
3650 9997 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3651 $ f11.5, ' SUSPECT *****' )
3652*
3653 RETURN
3654*
3655* End of PCBLAS3TSTCHK
3656*
cmplx
float cmplx[2]
Definition pblas.h:136
pcmmch1
subroutine pcmmch1(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pcblastst.f:5789
pcmmch
subroutine pcmmch(ictxt, transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pcblastst.f:5336
pcchkmin
subroutine pcchkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition pcblastst.f:3332
pcmmch2
subroutine pcmmch2(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pcblastst.f:6168
pcmmch3
subroutine pcmmch3(uplo, trans, m, n, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, err, info)
Definition pcblastst.f:6584
pb_claset
subroutine pb_claset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pcblastst.f:10047
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: