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

◆ pdblas3tstchk()

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

Definition at line 2732 of file pdblas3tst.f.

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