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

◆ psblas3tstchk()

subroutine psblas3tstchk ( 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,
real  alpha,
real, dimension( * )  a,
real, dimension( * )  pa,
integer  ia,
integer  ja,
integer, dimension( * )  desca,
real, dimension( * )  b,
real, dimension( * )  pb,
integer  ib,
integer  jb,
integer, dimension( * )  descb,
real  beta,
real, dimension( * )  c,
real, dimension( * )  pc,
integer  ic,
integer  jc,
integer, dimension( * )  descc,
real  thresh,
real  rogue,
real, dimension( * )  work,
integer  info 
)

Definition at line 2730 of file psblas3tst.f.

2735*
2736* -- PBLAS test routine (version 2.0) --
2737* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2738* and University of California, Berkeley.
2739* April 1, 1998
2740*
2741* .. Scalar Arguments ..
2742 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2743 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2744 $ NOUT, NROUT
2745 REAL ALPHA, BETA, ROGUE, THRESH
2746* ..
2747* .. Array Arguments ..
2748 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2749 REAL A( * ), B( * ), C( * ), PA( * ), PB( * ),
2750 $ PC( * ), WORK( * )
2751* ..
2752*
2753* Purpose
2754* =======
2755*
2756* PSBLAS3TSTCHK performs the computational tests of the Level 3 PBLAS.
2757*
2758* Notes
2759* =====
2760*
2761* A description vector is associated with each 2D block-cyclicly dis-
2762* tributed matrix. This vector stores the information required to
2763* establish the mapping between a matrix entry and its corresponding
2764* process and memory location.
2765*
2766* In the following comments, the character _ should be read as
2767* "of the distributed matrix". Let A be a generic term for any 2D
2768* block cyclicly distributed matrix. Its description vector is DESCA:
2769*
2770* NOTATION STORED IN EXPLANATION
2771* ---------------- --------------- ------------------------------------
2772* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2773* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2774* the NPROW x NPCOL BLACS process grid
2775* A is distributed over. The context
2776* itself is global, but the handle
2777* (the integer value) may vary.
2778* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2779* ted matrix A, M_A >= 0.
2780* N_A (global) DESCA( N_ ) The number of columns in the distri-
2781* buted matrix A, N_A >= 0.
2782* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2783* block of the matrix A, IMB_A > 0.
2784* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2785* left block of the matrix A,
2786* INB_A > 0.
2787* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2788* bute the last M_A-IMB_A rows of A,
2789* MB_A > 0.
2790* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2791* bute the last N_A-INB_A columns of
2792* A, NB_A > 0.
2793* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2794* row of the matrix A is distributed,
2795* NPROW > RSRC_A >= 0.
2796* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2797* first column of A is distributed.
2798* NPCOL > CSRC_A >= 0.
2799* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2800* array storing the local blocks of
2801* the distributed matrix A,
2802* IF( Lc( 1, N_A ) > 0 )
2803* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2804* ELSE
2805* LLD_A >= 1.
2806*
2807* Let K be the number of rows of a matrix A starting at the global in-
2808* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2809* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2810* receive if these K rows were distributed over NPROW processes. If K
2811* is the number of columns of a matrix A starting at the global index
2812* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2813* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2814* these K columns were distributed over NPCOL processes.
2815*
2816* The values of Lr() and Lc() may be determined via a call to the func-
2817* tion PB_NUMROC:
2818* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2819* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2820*
2821* Arguments
2822* =========
2823*
2824* ICTXT (local input) INTEGER
2825* On entry, ICTXT specifies the BLACS context handle, indica-
2826* ting the global context of the operation. The context itself
2827* is global, but the value of ICTXT is local.
2828*
2829* NOUT (global input) INTEGER
2830* On entry, NOUT specifies the unit number for the output file.
2831* When NOUT is 6, output to screen, when NOUT is 0, output to
2832* stderr. NOUT is only defined for process 0.
2833*
2834* NROUT (global input) INTEGER
2835* On entry, NROUT specifies which routine will be tested as
2836* follows:
2837* If NROUT = 1, PSGEMM will be tested;
2838* else if NROUT = 2, PSSYMM will be tested;
2839* else if NROUT = 3, PSSYRK will be tested;
2840* else if NROUT = 4, PSSYR2K will be tested;
2841* else if NROUT = 5, PSTRMM will be tested;
2842* else if NROUT = 6, PSTRSM will be tested;
2843* else if NROUT = 7, PSGEADD will be tested;
2844* else if NROUT = 8, PSTRADD will be tested;
2845*
2846* SIDE (global input) CHARACTER*1
2847* On entry, SIDE specifies if the multiplication should be per-
2848* formed from the left or the right.
2849*
2850* UPLO (global input) CHARACTER*1
2851* On entry, UPLO specifies if the upper or lower part of the
2852* matrix operand is to be referenced.
2853*
2854* TRANSA (global input) CHARACTER*1
2855* On entry, TRANSA specifies if the matrix operand A is to be
2856* transposed.
2857*
2858* TRANSB (global input) CHARACTER*1
2859* On entry, TRANSB specifies if the matrix operand B is to be
2860* transposed.
2861*
2862* DIAG (global input) CHARACTER*1
2863* On entry, DIAG specifies if the triangular matrix operand is
2864* unit or non-unit.
2865*
2866* M (global input) INTEGER
2867* On entry, M specifies the number of rows of C.
2868*
2869* N (global input) INTEGER
2870* On entry, N specifies the number of columns of C.
2871*
2872* K (global input) INTEGER
2873* On entry, K specifies the number of columns (resp. rows) of A
2874* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
2875* PxSYR2K, PxHERK and PxHER2K.
2876*
2877* ALPHA (global input) REAL
2878* On entry, ALPHA specifies the scalar alpha.
2879*
2880* A (local input/local output) REAL array
2881* On entry, A is an array of dimension (DESCA( M_ ),*). This
2882* array contains a local copy of the initial entire matrix PA.
2883*
2884* PA (local input) REAL array
2885* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
2886* array contains the local entries of the matrix PA.
2887*
2888* IA (global input) INTEGER
2889* On entry, IA specifies A's global row index, which points to
2890* the beginning of the submatrix sub( A ).
2891*
2892* JA (global input) INTEGER
2893* On entry, JA specifies A's global column index, which points
2894* to the beginning of the submatrix sub( A ).
2895*
2896* DESCA (global and local input) INTEGER array
2897* On entry, DESCA is an integer array of dimension DLEN_. This
2898* is the array descriptor for the matrix A.
2899*
2900* B (local input/local output) REAL array
2901* On entry, B is an array of dimension (DESCB( M_ ),*). This
2902* array contains a local copy of the initial entire matrix PB.
2903*
2904* PB (local input) REAL array
2905* On entry, PB is an array of dimension (DESCB( LLD_ ),*). This
2906* array contains the local entries of the matrix PB.
2907*
2908* IB (global input) INTEGER
2909* On entry, IB specifies B's global row index, which points to
2910* the beginning of the submatrix sub( B ).
2911*
2912* JB (global input) INTEGER
2913* On entry, JB specifies B's global column index, which points
2914* to the beginning of the submatrix sub( B ).
2915*
2916* DESCB (global and local input) INTEGER array
2917* On entry, DESCB is an integer array of dimension DLEN_. This
2918* is the array descriptor for the matrix B.
2919*
2920* BETA (global input) REAL
2921* On entry, BETA specifies the scalar beta.
2922*
2923* C (local input/local output) REAL array
2924* On entry, C is an array of dimension (DESCC( M_ ),*). This
2925* array contains a local copy of the initial entire matrix PC.
2926*
2927* PC (local input) REAL array
2928* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
2929* array contains the local pieces of the matrix PC.
2930*
2931* IC (global input) INTEGER
2932* On entry, IC specifies C's global row index, which points to
2933* the beginning of the submatrix sub( C ).
2934*
2935* JC (global input) INTEGER
2936* On entry, JC specifies C's global column index, which points
2937* to the beginning of the submatrix sub( C ).
2938*
2939* DESCC (global and local input) INTEGER array
2940* On entry, DESCC is an integer array of dimension DLEN_. This
2941* is the array descriptor for the matrix C.
2942*
2943* THRESH (global input) REAL
2944* On entry, THRESH is the threshold value for the test ratio.
2945*
2946* ROGUE (global input) REAL
2947* On entry, ROGUE specifies the constant used to pad the
2948* non-referenced part of triangular or symmetric matrices.
2949*
2950* WORK (workspace) REAL array
2951* On entry, WORK is an array of dimension LWORK where LWORK is
2952* at least 2*MAX( M, MAX( N, K ) ). This array is used to store
2953* a copy of a column of C and the computed gauges (see PSMMCH).
2954*
2955* INFO (global output) INTEGER
2956* On exit, if INFO = 0, no error has been found, otherwise
2957* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
2958* if( MOD( INFO/2, 2 ) = 1 ) then an error on B has been found,
2959* if( MOD( INFO/4, 2 ) = 1 ) then an error on C has been found.
2960*
2961* -- Written on April 1, 1998 by
2962* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2963*
2964* =====================================================================
2965*
2966* .. Parameters ..
2967 REAL ONE, ZERO
2968 parameter( one = 1.0e+0, zero = 0.0e+0 )
2969 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2970 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2971 $ RSRC_
2972 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2973 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2974 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2975 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2976* ..
2977* .. Local Scalars ..
2978 INTEGER I, IPG, MYCOL, MYROW, NPCOL, NPROW
2979 REAL ERR
2980* ..
2981* .. Local Arrays ..
2982 INTEGER IERR( 3 )
2983* ..
2984* .. External Subroutines ..
2985 EXTERNAL blacs_gridinfo, pb_slaset, pschkmin, psmmch,
2986 $ psmmch1, psmmch2, psmmch3, pstrmm, strsm
2987* ..
2988* .. External Functions ..
2989 LOGICAL LSAME
2990 EXTERNAL lsame
2991* ..
2992* .. Executable Statements ..
2993*
2994 info = 0
2995*
2996* Quick return if possible
2997*
2998 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
2999 $ RETURN
3000*
3001* Start the operations
3002*
3003 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3004*
3005 DO 10 i = 1, 3
3006 ierr( i ) = 0
3007 10 CONTINUE
3008 ipg = max( m, max( n, k ) ) + 1
3009*
3010 IF( nrout.EQ.1 ) THEN
3011*
3012* Test PSGEMM
3013*
3014* Check the resulting matrix C
3015*
3016 CALL psmmch( ictxt, transa, transb, m, n, k, alpha, a, ia, ja,
3017 $ desca, b, ib, jb, descb, beta, c, pc, ic, jc,
3018 $ descc, work, work( ipg ), err, ierr( 3 ) )
3019*
3020 IF( ierr( 3 ).NE.0 ) THEN
3021 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3022 $ WRITE( nout, fmt = 9998 )
3023 ELSE IF( err.GT.thresh ) THEN
3024 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3025 $ WRITE( nout, fmt = 9997 ) err
3026 END IF
3027*
3028* Check the input-only arguments
3029*
3030 IF( lsame( transa, 'N' ) ) THEN
3031 CALL pschkmin( err, m, k, a, pa, ia, ja, desca, ierr( 1 ) )
3032 ELSE
3033 CALL pschkmin( err, k, m, a, pa, ia, ja, desca, ierr( 1 ) )
3034 END IF
3035 IF( lsame( transb, 'N' ) ) THEN
3036 CALL pschkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3037 ELSE
3038 CALL pschkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3039 END IF
3040*
3041 ELSE IF( nrout.EQ.2 ) THEN
3042*
3043* Test PSSYMM
3044*
3045* Check the resulting matrix C
3046*
3047 IF( lsame( side, 'L' ) ) THEN
3048 CALL psmmch( ictxt, 'No transpose', 'No transpose', m, n, m,
3049 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3050 $ beta, c, pc, ic, jc, descc, work, work( ipg ),
3051 $ err, ierr( 3 ) )
3052 ELSE
3053 CALL psmmch( ictxt, 'No transpose', 'No transpose', m, n, n,
3054 $ alpha, b, ib, jb, descb, a, ia, ja, desca,
3055 $ beta, c, pc, ic, jc, descc, work, work( ipg ),
3056 $ err, ierr( 3 ) )
3057 END IF
3058*
3059 IF( ierr( 3 ).NE.0 ) THEN
3060 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3061 $ WRITE( nout, fmt = 9998 )
3062 ELSE IF( err.GT.thresh ) THEN
3063 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3064 $ WRITE( nout, fmt = 9997 ) err
3065 END IF
3066*
3067* Check the input-only arguments
3068*
3069 IF( lsame( uplo, 'L' ) ) THEN
3070 IF( lsame( side, 'L' ) ) THEN
3071 CALL pb_slaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3072 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3073 ELSE
3074 CALL pb_slaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3075 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3076 END IF
3077 ELSE
3078 IF( lsame( side, 'L' ) ) THEN
3079 CALL pb_slaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3080 $ a( ia+1+(ja-1)*desca( m_ ) ),
3081 $ desca( m_ ) )
3082 ELSE
3083 CALL pb_slaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3084 $ a( ia+1+(ja-1)*desca( m_ ) ),
3085 $ desca( m_ ) )
3086 END IF
3087 END IF
3088*
3089 IF( lsame( side, 'L' ) ) THEN
3090 CALL pschkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3091 ELSE
3092 CALL pschkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3093 END IF
3094 CALL pschkmin( err, m, n, b, pb, ib, jb, descb, ierr( 2 ) )
3095*
3096 ELSE IF( nrout.EQ.3 ) THEN
3097*
3098* Test PSSYRK
3099*
3100* Check the resulting matrix C
3101*
3102 IF( lsame( transa, 'N' ) ) THEN
3103 CALL psmmch1( ictxt, uplo, 'No transpose', n, k, alpha, a,
3104 $ ia, ja, desca, beta, c, pc, ic, jc, descc,
3105 $ work, work( ipg ), err, ierr( 3 ) )
3106 ELSE
3107 CALL psmmch1( ictxt, uplo, 'Transpose', n, k, alpha, a, ia,
3108 $ ja, desca, beta, c, pc, ic, jc, descc, work,
3109 $ work( ipg ), err, ierr( 3 ) )
3110 END IF
3111*
3112 IF( ierr( 3 ).NE.0 ) THEN
3113 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3114 $ WRITE( nout, fmt = 9998 )
3115 ELSE IF( err.GT.thresh ) THEN
3116 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3117 $ WRITE( nout, fmt = 9997 ) err
3118 END IF
3119*
3120* Check the input-only arguments
3121*
3122 IF( lsame( transa, 'N' ) ) THEN
3123 CALL pschkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3124 ELSE
3125 CALL pschkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3126 END IF
3127*
3128 ELSE IF( nrout.EQ.4 ) THEN
3129*
3130* Test PSSYR2K
3131*
3132* Check the resulting matrix C
3133*
3134 IF( lsame( transa, 'N' ) ) THEN
3135 CALL psmmch2( ictxt, uplo, 'No transpose', n, k, alpha, a,
3136 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3137 $ ic, jc, descc, work, work( ipg ), err,
3138 $ ierr( 3 ) )
3139 ELSE
3140 CALL psmmch2( ictxt, uplo, 'Transpose', n, k, alpha, a,
3141 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3142 $ ic, jc, descc, work, work( ipg ), err,
3143 $ ierr( 3 ) )
3144 END IF
3145*
3146 IF( ierr( 3 ).NE.0 ) THEN
3147 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3148 $ WRITE( nout, fmt = 9998 )
3149 ELSE IF( err.GT.thresh ) THEN
3150 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3151 $ WRITE( nout, fmt = 9997 ) err
3152 END IF
3153*
3154* Check the input-only arguments
3155*
3156 IF( lsame( transa, 'N' ) ) THEN
3157 CALL pschkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3158 CALL pschkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3159 ELSE
3160 CALL pschkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3161 CALL pschkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3162 END IF
3163*
3164 ELSE IF( nrout.EQ.5 ) THEN
3165*
3166* Test PSTRMM
3167*
3168* Check the resulting matrix B
3169*
3170 IF( lsame( side, 'L' ) ) THEN
3171 CALL psmmch( ictxt, transa, 'No transpose', m, n, m,
3172 $ alpha, a, ia, ja, desca, c, ib, jb, descb,
3173 $ zero, b, pb, ib, jb, descb, work,
3174 $ work( ipg ), err, ierr( 2 ) )
3175 ELSE
3176 CALL psmmch( ictxt, 'No transpose', transa, m, n, n,
3177 $ alpha, c, ib, jb, descb, a, ia, ja, desca,
3178 $ zero, b, pb, ib, jb, descb, work,
3179 $ work( ipg ), err, ierr( 2 ) )
3180 END IF
3181*
3182 IF( ierr( 2 ).NE.0 ) THEN
3183 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3184 $ WRITE( nout, fmt = 9998 )
3185 ELSE IF( err.GT.thresh ) THEN
3186 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3187 $ WRITE( nout, fmt = 9997 ) err
3188 END IF
3189*
3190* Check the input-only arguments
3191*
3192 IF( lsame( side, 'L' ) ) THEN
3193 IF( lsame( uplo, 'L' ) ) THEN
3194 IF( lsame( diag, 'N' ) ) THEN
3195 CALL pb_slaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3196 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3197 ELSE
3198 CALL pb_slaset( 'Upper', m, m, 0, rogue, one,
3199 $ a( ia+(ja-1)*desca( m_ ) ),
3200 $ desca( m_ ) )
3201 END IF
3202 ELSE
3203 IF( lsame( diag, 'N' ) ) THEN
3204 CALL pb_slaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3205 $ a( ia+1+(ja-1)*desca( m_ ) ),
3206 $ desca( m_ ) )
3207 ELSE
3208 CALL pb_slaset( 'Lower', m, m, 0, rogue, one,
3209 $ a( ia+(ja-1)*desca( m_ ) ),
3210 $ desca( m_ ) )
3211 END IF
3212 END IF
3213 CALL pschkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3214 ELSE
3215 IF( lsame( uplo, 'L' ) ) THEN
3216 IF( lsame( diag, 'N' ) ) THEN
3217 CALL pb_slaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3218 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3219 ELSE
3220 CALL pb_slaset( 'Upper', n, n, 0, rogue, one,
3221 $ a( ia+(ja-1)*desca( m_ ) ),
3222 $ desca( m_ ) )
3223 END IF
3224 ELSE
3225 IF( lsame( diag, 'N' ) ) THEN
3226 CALL pb_slaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3227 $ a( ia+1+(ja-1)*desca( m_ ) ),
3228 $ desca( m_ ) )
3229 ELSE
3230 CALL pb_slaset( 'Lower', n, n, 0, rogue, one,
3231 $ a( ia+(ja-1)*desca( m_ ) ),
3232 $ desca( m_ ) )
3233 END IF
3234 END IF
3235 CALL pschkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3236 END IF
3237*
3238 ELSE IF( nrout.EQ.6 ) THEN
3239*
3240* Test PSTRSM
3241*
3242* Check the resulting matrix B
3243*
3244 CALL strsm( side, uplo, transa, diag, m, n, alpha,
3245 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ),
3246 $ b( ib+(jb-1)*descb( m_ ) ), descb( m_ ) )
3247 CALL pstrmm( side, uplo, transa, diag, m, n, alpha, pa, ia, ja,
3248 $ desca, pb, ib, jb, descb )
3249 IF( lsame( side, 'L' ) ) THEN
3250 CALL psmmch( ictxt, transa, 'No transpose', m, n, m, alpha,
3251 $ a, ia, ja, desca, b, ib, jb, descb, zero, c,
3252 $ pb, ib, jb, descb, work, work( ipg ), err,
3253 $ ierr( 2 ) )
3254 ELSE
3255 CALL psmmch( ictxt, 'No transpose', transa, m, n, n, alpha,
3256 $ b, ib, jb, descb, a, ia, ja, desca, zero, c,
3257 $ pb, ib, jb, descb, work, work( ipg ), err,
3258 $ ierr( 2 ) )
3259 END IF
3260*
3261 IF( ierr( 2 ).NE.0 ) THEN
3262 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3263 $ WRITE( nout, fmt = 9998 )
3264 ELSE IF( err.GT.thresh ) THEN
3265 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3266 $ WRITE( nout, fmt = 9997 ) err
3267 END IF
3268*
3269* Check the input-only arguments
3270*
3271 IF( lsame( side, 'L' ) ) THEN
3272 IF( lsame( uplo, 'L' ) ) THEN
3273 IF( lsame( diag, 'N' ) ) THEN
3274 CALL pb_slaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3275 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3276 ELSE
3277 CALL pb_slaset( 'Upper', m, m, 0, rogue, one,
3278 $ a( ia+(ja-1)*desca( m_ ) ),
3279 $ desca( m_ ) )
3280 END IF
3281 ELSE
3282 IF( lsame( diag, 'N' ) ) THEN
3283 CALL pb_slaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3284 $ a( ia+1+(ja-1)*desca( m_ ) ),
3285 $ desca( m_ ) )
3286 ELSE
3287 CALL pb_slaset( 'Lower', m, m, 0, rogue, one,
3288 $ a( ia+(ja-1)*desca( m_ ) ),
3289 $ desca( m_ ) )
3290 END IF
3291 END IF
3292 CALL pschkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3293 ELSE
3294 IF( lsame( uplo, 'L' ) ) THEN
3295 IF( lsame( diag, 'N' ) ) THEN
3296 CALL pb_slaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3297 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3298 ELSE
3299 CALL pb_slaset( 'Upper', n, n, 0, rogue, one,
3300 $ a( ia+(ja-1)*desca( m_ ) ),
3301 $ desca( m_ ) )
3302 END IF
3303 ELSE
3304 IF( lsame( diag, 'N' ) ) THEN
3305 CALL pb_slaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3306 $ a( ia+1+(ja-1)*desca( m_ ) ),
3307 $ desca( m_ ) )
3308 ELSE
3309 CALL pb_slaset( 'Lower', n, n, 0, rogue, one,
3310 $ a( ia+(ja-1)*desca( m_ ) ),
3311 $ desca( m_ ) )
3312 END IF
3313 END IF
3314 CALL pschkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3315 END IF
3316 ELSE IF( nrout.EQ.7 ) THEN
3317*
3318* Test PSGEADD
3319*
3320* Check the resulting matrix C
3321*
3322 CALL psmmch3( 'All', transa, m, n, alpha, a, ia, ja, desca,
3323 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3324*
3325* Check the input-only arguments
3326*
3327 IF( lsame( transa, 'N' ) ) THEN
3328 CALL pschkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3329 ELSE
3330 CALL pschkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3331 END IF
3332*
3333 ELSE IF( nrout.EQ.8 ) THEN
3334*
3335* Test PSTRADD
3336*
3337* Check the resulting matrix C
3338*
3339 CALL psmmch3( uplo, transa, m, n, alpha, a, ia, ja, desca,
3340 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3341*
3342* Check the input-only arguments
3343*
3344 IF( lsame( transa, 'N' ) ) THEN
3345 CALL pschkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3346 ELSE
3347 CALL pschkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3348 END IF
3349*
3350 END IF
3351*
3352 IF( ierr( 1 ).NE.0 ) THEN
3353 info = info + 1
3354 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3355 $ WRITE( nout, fmt = 9999 ) 'A'
3356 END IF
3357*
3358 IF( ierr( 2 ).NE.0 ) THEN
3359 info = info + 2
3360 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3361 $ WRITE( nout, fmt = 9999 ) 'B'
3362 END IF
3363*
3364 IF( ierr( 3 ).NE.0 ) THEN
3365 info = info + 4
3366 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3367 $ WRITE( nout, fmt = 9999 ) 'C'
3368 END IF
3369*
3370 9999 FORMAT( 2x, ' ***** ERROR: Matrix operand ', a,
3371 $ ' is incorrect.' )
3372 9998 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3373 $ 'than half accurate *****' )
3374 9997 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3375 $ f11.5, ' SUSPECT *****' )
3376*
3377 RETURN
3378*
3379* End of PSBLAS3TSTCHK
3380*
max
#define max(A, B)
Definition pcgemr.c:180
pschkmin
subroutine pschkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition psblastst.f:3326
psmmch
subroutine psmmch(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 psblastst.f:5272
pb_slaset
subroutine pb_slaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition psblastst.f:9361
psmmch2
subroutine psmmch2(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 psblastst.f:5996
psmmch1
subroutine psmmch1(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition psblastst.f:5649
psmmch3
subroutine psmmch3(uplo, trans, m, n, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, err, info)
Definition psblastst.f:6372
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: