1 SUBROUTINE pspblaschk( SYMM, UPLO, N, BWL, BWU, NRHS, X, IX, JX,
2 $ DESCX, IASEED, A, IA, JA, DESCA, IBSEED,
3 $ ANORM, RESID, WORK, WORKSIZ )
13 INTEGER BWL, BWU, IA, IASEED, IBSEED,
14 $ ix, ja, jx, n, nrhs, worksiz
18 INTEGER DESCA( * ), DESCX( * )
19 REAL A( * ), WORK( * ), X( * )
162 PARAMETER ( ONE = 1.0e+0, zero = 0.0e+0 )
163 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
164 $ lld_, mb_, m_, nb_, n_, rsrc_
165 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
166 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
167 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
169 PARAMETER ( INT_ONE = 1 )
172 INTEGER IACOL, IAROW, ICTXT,
173 $ IIA, IIX, IPB, IPW,
174 $ ixcol, ixrow, j, jja, jjx, lda,
175 $ mycol, myrow, nb, np, npcol, nprow, nq
176 INTEGER BW, INFO, IPPRODUCT, WORK_MIN
177 REAL DIVISOR, EPS, RESID1, NORMX
183 $ sgamx2d, sgebr2d, sgebs2d, sgemm,
184 $ sgerv2d, sgesd2d, sgsum2d, slaset
187 INTEGER ISAMAX, NUMROC
189 EXTERNAL isamax, numroc, pslamch
192 INTRINSIC abs,
max,
min, mod, real
198 ictxt = desca( ctxt_ )
201 IF( lsame( symm,
'S' ) )
THEN
203 work_min =
max(5,
max(bw*(bw+2),nb))+2*nb
206 work_min =
max(5,
max(bw*(bw+2),nb))+2*nb
209 IF ( worksiz .LT. work_min )
THEN
210 CALL pxerbla( ictxt,
'PSBLASCHK', -18 )
214 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
216 eps = pslamch( ictxt,
'eps' )
218 divisor = anorm * eps * real( n )
220 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia, jja,
222 CALL infog2l( ix, jx, descx, nprow, npcol, myrow, mycol, iix, jjx,
224 np = numroc( (bw+1), desca( mb_ ), myrow, 0, nprow )
225 nq = numroc( n, desca( nb_ ), mycol, 0, npcol )
228 ipproduct = 1 + desca( nb_ )
229 ipw = 1 + 2*desca( nb_ )
235 IF( lsame( symm,
'S' ))
THEN
236 CALL psbmatgen( ictxt, uplo,
'D', bw, bw, n, bw+1,
237 $ desca( nb_ ), a, desca( lld_ ), 0, 0,
238 $ iaseed, myrow, mycol, nprow, npcol )
241 CALL psbmatgen( ictxt,
'N', uplo, bwl, bwu, n,
242 $ desca( mb_ ), desca( nb_ ), a,
243 $ desca( lld_ ), 0, 0, iaseed, myrow,
244 $ mycol, nprow, npcol )
256 CALL pspbdcmv( bw+1, bw, uplo, n, a, 1, desca,
257 $ 1, x( 1 + (j-1)*descx( lld_ )), 1, descx,
258 $ work( ipproduct ), work( ipw ), (bw+2)*bw, info )
263 CALL psmatgen( descx( ctxt_ ),
'No',
'No', descx( m_ ),
264 $ descx( n_ ), descx( mb_ ), descx( nb_ ),
265 $ work( ipb ), descx( lld_ ), descx( rsrc_ ),
266 $ descx( csrc_ ), ibseed, 0, nq, j-1, 1, mycol,
267 $ myrow, npcol, nprow )
271 CALL psaxpy( n, -one, work( ipproduct ), 1, 1, descx, 1,
272 $ work( ipb ), 1, 1, descx, 1 )
274 CALL psnrm2( n, normx,
275 $ x, 1, j, descx, 1 )
277 CALL psnrm2( n, resid1,
278 $ work( ipb ), 1, 1, descx, 1 )
283 resid1 = resid1 / ( normx*divisor )
285 resid =
max( resid, resid1 )