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

◆ pcchkvout()

subroutine pcchkvout ( integer  n,
complex, dimension( * )  x,
complex, dimension( * )  px,
integer  ix,
integer  jx,
integer, dimension( * )  descx,
integer  incx,
integer  info 
)

Definition at line 2875 of file pcblastst.f.

2876*
2877* -- PBLAS test routine (version 2.0) --
2878* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2879* and University of California, Berkeley.
2880* April 1, 1998
2881*
2882* .. Scalar Arguments ..
2883 INTEGER INCX, INFO, IX, JX, N
2884* ..
2885* .. Array Arguments ..
2886 INTEGER DESCX( * )
2887 COMPLEX PX( * ), X( * )
2888* ..
2889*
2890* Purpose
2891* =======
2892*
2893* PCCHKVOUT checks that the matrix PX \ sub( PX ) remained unchanged.
2894* The local array entries are compared element by element, and their
2895* difference is tested against 0.0 as well as the epsilon machine. No-
2896* tice that this difference should be numerically exactly the zero ma-
2897* chine, but because of the possible movement of some of the data we
2898* flagged differently a difference less than twice the epsilon machine.
2899* The largest error is reported.
2900*
2901* Notes
2902* =====
2903*
2904* A description vector is associated with each 2D block-cyclicly dis-
2905* tributed matrix. This vector stores the information required to
2906* establish the mapping between a matrix entry and its corresponding
2907* process and memory location.
2908*
2909* In the following comments, the character _ should be read as
2910* "of the distributed matrix". Let A be a generic term for any 2D
2911* block cyclicly distributed matrix. Its description vector is DESCA:
2912*
2913* NOTATION STORED IN EXPLANATION
2914* ---------------- --------------- ------------------------------------
2915* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2916* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2917* the NPROW x NPCOL BLACS process grid
2918* A is distributed over. The context
2919* itself is global, but the handle
2920* (the integer value) may vary.
2921* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2922* ted matrix A, M_A >= 0.
2923* N_A (global) DESCA( N_ ) The number of columns in the distri-
2924* buted matrix A, N_A >= 0.
2925* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2926* block of the matrix A, IMB_A > 0.
2927* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2928* left block of the matrix A,
2929* INB_A > 0.
2930* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2931* bute the last M_A-IMB_A rows of A,
2932* MB_A > 0.
2933* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2934* bute the last N_A-INB_A columns of
2935* A, NB_A > 0.
2936* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2937* row of the matrix A is distributed,
2938* NPROW > RSRC_A >= 0.
2939* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2940* first column of A is distributed.
2941* NPCOL > CSRC_A >= 0.
2942* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2943* array storing the local blocks of
2944* the distributed matrix A,
2945* IF( Lc( 1, N_A ) > 0 )
2946* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2947* ELSE
2948* LLD_A >= 1.
2949*
2950* Let K be the number of rows of a matrix A starting at the global in-
2951* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2952* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2953* receive if these K rows were distributed over NPROW processes. If K
2954* is the number of columns of a matrix A starting at the global index
2955* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2956* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2957* these K columns were distributed over NPCOL processes.
2958*
2959* The values of Lr() and Lc() may be determined via a call to the func-
2960* tion PB_NUMROC:
2961* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2962* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2963*
2964* Arguments
2965* =========
2966*
2967* N (global input) INTEGER
2968* On entry, N specifies the length of the subvector operand
2969* sub( X ). N must be at least zero.
2970*
2971* X (local input) COMPLEX array
2972* On entry, X is an array of dimension (DESCX( M_ ),*). This
2973* array contains a local copy of the initial entire matrix PX.
2974*
2975* PX (local input) COMPLEX array
2976* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2977* array contains the local entries of the matrix PX.
2978*
2979* IX (global input) INTEGER
2980* On entry, IX specifies X's global row index, which points to
2981* the beginning of the submatrix sub( X ).
2982*
2983* JX (global input) INTEGER
2984* On entry, JX specifies X's global column index, which points
2985* to the beginning of the submatrix sub( X ).
2986*
2987* DESCX (global and local input) INTEGER array
2988* On entry, DESCX is an integer array of dimension DLEN_. This
2989* is the array descriptor for the matrix X.
2990*
2991* INCX (global input) INTEGER
2992* On entry, INCX specifies the global increment for the
2993* elements of X. Only two values of INCX are supported in
2994* this version, namely 1 and M_X. INCX must not be zero.
2995*
2996* INFO (global output) INTEGER
2997* On exit, if INFO = 0, no error has been found,
2998* If INFO > 0, the maximum abolute error found is in (0,eps],
2999* If INFO < 0, the maximum abolute error found is in (eps,+oo).
3000*
3001* -- Written on April 1, 1998 by
3002* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3003*
3004* =====================================================================
3005*
3006* .. Parameters ..
3007 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3008 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3009 $ RSRC_
3010 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3011 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3012 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3013 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3014 REAL ZERO
3015 parameter( zero = 0.0e+0 )
3016* ..
3017* .. Local Scalars ..
3018 LOGICAL COLREP, ROWREP
3019 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
3020 $ J, JB, JJ, KK, LDPX, LDX, LL, MBX, MPALL,
3021 $ MYCOL, MYCOLDIST, MYROW, MYROWDIST, NBX, NPCOL,
3022 $ NPROW, NQALL
3023 REAL EPS, ERR, ERRMAX
3024* ..
3025* .. External Subroutines ..
3026 EXTERNAL blacs_gridinfo, pcerrset, sgamx2d
3027* ..
3028* .. External Functions ..
3029 INTEGER PB_NUMROC
3030 REAL PSLAMCH
3031 EXTERNAL pslamch, pb_numroc
3032* ..
3033* .. Intrinsic Functions ..
3034 INTRINSIC abs, aimag, max, min, mod, real
3035* ..
3036* .. Executable Statements ..
3037*
3038 info = 0
3039 errmax = zero
3040*
3041* Quick return if possible
3042*
3043 IF( ( descx( m_ ).LE.0 ).OR.( descx( n_ ).LE.0 ) )
3044 $ RETURN
3045*
3046* Start the operations
3047*
3048 ictxt = descx( ctxt_ )
3049 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3050*
3051 eps = pslamch( ictxt, 'eps' )
3052*
3053 mpall = pb_numroc( descx( m_ ), 1, descx( imb_ ), descx( mb_ ),
3054 $ myrow, descx( rsrc_ ), nprow )
3055 nqall = pb_numroc( descx( n_ ), 1, descx( inb_ ), descx( nb_ ),
3056 $ mycol, descx( csrc_ ), npcol )
3057*
3058 mbx = descx( mb_ )
3059 nbx = descx( nb_ )
3060 ldx = descx( m_ )
3061 ldpx = descx( lld_ )
3062 icurrow = descx( rsrc_ )
3063 icurcol = descx( csrc_ )
3064 rowrep = ( icurrow.EQ.-1 )
3065 colrep = ( icurcol.EQ.-1 )
3066 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3067 imbx = descx( imb_ )
3068 ELSE
3069 imbx = mbx
3070 END IF
3071 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3072 inbx = descx( inb_ )
3073 ELSE
3074 inbx = nbx
3075 END IF
3076 IF( rowrep ) THEN
3077 myrowdist = 0
3078 ELSE
3079 myrowdist = mod( myrow - icurrow + nprow, nprow )
3080 END IF
3081 IF( colrep ) THEN
3082 mycoldist = 0
3083 ELSE
3084 mycoldist = mod( mycol - icurcol + npcol, npcol )
3085 END IF
3086 ii = 1
3087 jj = 1
3088*
3089 IF( incx.EQ.descx( m_ ) ) THEN
3090*
3091* sub( X ) is a row vector
3092*
3093 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3094*
3095 i = 1
3096 IF( mycoldist.EQ.0 ) THEN
3097 j = 1
3098 ELSE
3099 j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3100 END IF
3101 jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3102 ib = min( descx( m_ ), descx( imb_ ) )
3103*
3104 DO 20 kk = 0, jb-1
3105 DO 10 ll = 0, ib-1
3106 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR. j+kk.GT.jx+n-1 )
3107 $ CALL pcerrset( err, errmax,
3108 $ x( i+ll+(j+kk-1)*ldx ),
3109 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3110 10 CONTINUE
3111 20 CONTINUE
3112 IF( colrep ) THEN
3113 j = j + inbx
3114 ELSE
3115 j = j + inbx + ( npcol - 1 ) * nbx
3116 END IF
3117*
3118 DO 50 jj = inbx+1, nqall, nbx
3119 jb = min( nqall-jj+1, nbx )
3120*
3121 DO 40 kk = 0, jb-1
3122 DO 30 ll = 0, ib-1
3123 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3124 $ j+kk.GT.jx+n-1 )
3125 $ CALL pcerrset( err, errmax,
3126 $ x( i+ll+(j+kk-1)*ldx ),
3127 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3128 30 CONTINUE
3129 40 CONTINUE
3130*
3131 IF( colrep ) THEN
3132 j = j + nbx
3133 ELSE
3134 j = j + npcol * nbx
3135 END IF
3136*
3137 50 CONTINUE
3138*
3139 ii = ii + ib
3140*
3141 END IF
3142*
3143 icurrow = mod( icurrow + 1, nprow )
3144*
3145 DO 110 i = descx( imb_ ) + 1, descx( m_ ), mbx
3146 ib = min( descx( m_ ) - i + 1, mbx )
3147*
3148 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3149*
3150 IF( mycoldist.EQ.0 ) THEN
3151 j = 1
3152 ELSE
3153 j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3154 END IF
3155*
3156 jj = 1
3157 jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3158 DO 70 kk = 0, jb-1
3159 DO 60 ll = 0, ib-1
3160 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3161 $ j+kk.GT.jx+n-1 )
3162 $ CALL pcerrset( err, errmax,
3163 $ x( i+ll+(j+kk-1)*ldx ),
3164 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3165 60 CONTINUE
3166 70 CONTINUE
3167 IF( colrep ) THEN
3168 j = j + inbx
3169 ELSE
3170 j = j + inbx + ( npcol - 1 ) * nbx
3171 END IF
3172*
3173 DO 100 jj = inbx+1, nqall, nbx
3174 jb = min( nqall-jj+1, nbx )
3175*
3176 DO 90 kk = 0, jb-1
3177 DO 80 ll = 0, ib-1
3178 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3179 $ j+kk.GT.jx+n-1 )
3180 $ CALL pcerrset( err, errmax,
3181 $ x( i+ll+(j+kk-1)*ldx ),
3182 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3183 80 CONTINUE
3184 90 CONTINUE
3185*
3186 IF( colrep ) THEN
3187 j = j + nbx
3188 ELSE
3189 j = j + npcol * nbx
3190 END IF
3191*
3192 100 CONTINUE
3193*
3194 ii = ii + ib
3195*
3196 END IF
3197*
3198 icurrow = mod( icurrow + 1, nprow )
3199*
3200 110 CONTINUE
3201*
3202 ELSE
3203*
3204* sub( X ) is a column vector
3205*
3206 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3207*
3208 j = 1
3209 IF( myrowdist.EQ.0 ) THEN
3210 i = 1
3211 ELSE
3212 i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3213 END IF
3214 ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3215 jb = min( descx( n_ ), descx( inb_ ) )
3216*
3217 DO 130 kk = 0, jb-1
3218 DO 120 ll = 0, ib-1
3219 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR. i+ll.GT.ix+n-1 )
3220 $ CALL pcerrset( err, errmax,
3221 $ x( i+ll+(j+kk-1)*ldx ),
3222 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3223 120 CONTINUE
3224 130 CONTINUE
3225 IF( rowrep ) THEN
3226 i = i + imbx
3227 ELSE
3228 i = i + imbx + ( nprow - 1 ) * mbx
3229 END IF
3230*
3231 DO 160 ii = imbx+1, mpall, mbx
3232 ib = min( mpall-ii+1, mbx )
3233*
3234 DO 150 kk = 0, jb-1
3235 DO 140 ll = 0, ib-1
3236 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3237 $ i+ll.GT.ix+n-1 )
3238 $ CALL pcerrset( err, errmax,
3239 $ x( i+ll+(j+kk-1)*ldx ),
3240 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3241 140 CONTINUE
3242 150 CONTINUE
3243*
3244 IF( rowrep ) THEN
3245 i = i + mbx
3246 ELSE
3247 i = i + nprow * mbx
3248 END IF
3249*
3250 160 CONTINUE
3251*
3252 jj = jj + jb
3253*
3254 END IF
3255*
3256 icurcol = mod( icurcol + 1, npcol )
3257*
3258 DO 220 j = descx( inb_ ) + 1, descx( n_ ), nbx
3259 jb = min( descx( n_ ) - j + 1, nbx )
3260*
3261 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3262*
3263 IF( myrowdist.EQ.0 ) THEN
3264 i = 1
3265 ELSE
3266 i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3267 END IF
3268*
3269 ii = 1
3270 ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3271 DO 180 kk = 0, jb-1
3272 DO 170 ll = 0, ib-1
3273 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3274 $ i+ll.GT.ix+n-1 )
3275 $ CALL pcerrset( err, errmax,
3276 $ x( i+ll+(j+kk-1)*ldx ),
3277 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3278 170 CONTINUE
3279 180 CONTINUE
3280 IF( rowrep ) THEN
3281 i = i + imbx
3282 ELSE
3283 i = i + imbx + ( nprow - 1 ) * mbx
3284 END IF
3285*
3286 DO 210 ii = imbx+1, mpall, mbx
3287 ib = min( mpall-ii+1, mbx )
3288*
3289 DO 200 kk = 0, jb-1
3290 DO 190 ll = 0, ib-1
3291 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3292 $ i+ll.GT.ix+n-1 )
3293 $ CALL pcerrset( err, errmax,
3294 $ x( i+ll+(j+kk-1)*ldx ),
3295 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3296 190 CONTINUE
3297 200 CONTINUE
3298*
3299 IF( rowrep ) THEN
3300 i = i + mbx
3301 ELSE
3302 i = i + nprow * mbx
3303 END IF
3304*
3305 210 CONTINUE
3306*
3307 jj = jj + jb
3308*
3309 END IF
3310*
3311 icurcol = mod( icurcol + 1, npcol )
3312*
3313 220 CONTINUE
3314*
3315 END IF
3316*
3317 CALL sgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3318 $ -1, -1 )
3319*
3320 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3321 info = 1
3322 ELSE IF( errmax.GT.eps ) THEN
3323 info = -1
3324 END IF
3325*
3326 RETURN
3327*
3328* End of PCCHKVOUT
3329*
pb_numroc
integer function pb_numroc(n, i, inb, nb, proc, srcproc, nprocs)
Definition pblastst.f:2548
pcerrset
subroutine pcerrset(err, errmax, xtrue, x)
Definition pcblastst.f:2460
pslamch
real function pslamch(ictxt, cmach)
Definition pcblastst.f:7455
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
Here is the caller graph for this function: