1 SUBROUTINE pdlafchk( AFORM, DIAG, M, N, A, IA, JA, DESCA, IASEED,
2 $ ANORM, FRESID, WORK )
11 INTEGER IA, IASEED, JA, M, N
12 DOUBLE PRECISION ANORM, FRESID
16 DOUBLE PRECISION A( * ), WORK( * )
148 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
149 $ lld_, mb_, m_, nb_, n_, rsrc_
150 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
151 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
152 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
154 parameter( one = 1.0d+0 )
157 INTEGER IACOL, IAROW, ICOFF, ICTXT, IIA, IOFFA, IROFF,
158 $ jb, jj, jja, jn, lda, ldw, mp, mycol, myrow,
166 INTEGER ICEIL, NUMROC
167 DOUBLE PRECISION PDLAMCH, PDLANGE
168 EXTERNAL iceil, numroc, pdlamch, pdlange
175 ictxt = desca( ctxt_ )
176 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
177 eps = pdlamch( ictxt,
'eps' )
178 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia, jja,
183 iroff = mod( ia-1, desca( mb_ ) )
184 icoff = mod( ja-1, desca( nb_ ) )
185 mp = numroc( m+iroff, desca( mb_ ), myrow, iarow, nprow )
186 nq = numroc( n+icoff, desca( nb_ ), mycol, iacol, npcol )
191 jn =
min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
194 ioffa = iia + ( jja - 1 )*lda
198 IF( mycol.EQ.iacol )
THEN
200 CALL pdmatgen( ictxt, aform, diag, desca( m_ ), desca( n_ ),
201 $ desca( mb_ ), desca( nb_ ), work, ldw,
202 $ desca( rsrc_ ), desca( csrc_ ), iaseed, iia-1,
203 $ mp, jja-1, jb, myrow, mycol, nprow, npcol )
204 CALL dmatadd( mp, jb, -one, work, ldw, one, a( ioffa ), lda )
207 ioffa = ioffa + jb * lda
212 DO 10 jj = jja, jja+nq-1, desca( nb_ )
213 jb =
min( desca( nb_ ), jja+nq-jj )
214 ioffa = iia + ( jj - 1 ) * lda
215 CALL pdmatgen( ictxt, aform, diag, desca( m_ ), desca( n_ ),
216 $ desca( mb_ ), desca( nb_ ), work, ldw,
217 $ desca( rsrc_ ), desca( csrc_ ), iaseed, iia-1,
218 $ mp, jj-1, jb, myrow, mycol, nprow, npcol )
219 CALL dmatadd( mp, jb, -one, work, ldw, one, a( ioffa ), lda )
224 fresid = pdlange(
'I', m, n, a, ia, ja, desca, work ) /
225 $ (
max( m, n ) * eps * anorm )