1 SUBROUTINE pclaprnt( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
10 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT
15 COMPLEX A( * ), WORK( * )
124 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
125 $ lld_, mb_, m_, nb_, n_, rsrc_
126 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
127 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
128 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
131 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
132 $ icurrow, ii, iia, in, j, jb, jj, jja, jn, k,
133 $ lda, mycol, myrow, npcol, nprow
136 EXTERNAL blacs_barrier, blacs_gridinfo,
infog2l,
144 INTRINSIC aimag,
min, real
150 ictxt = desca( ctxt_ )
151 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
153 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
154 $ iia, jja, iarow, iacol )
163 jn =
min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
166 in =
min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
168 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt )
THEN
169 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
171 WRITE( nout, fmt = 9999 )
172 $ cmatnm, ia+k, ja+h,
173 $ real( a(ii+k+(jj+h-1)*lda) ),
174 $ aimag( a(ii+k+(jj+h-1)*lda) )
178 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol )
THEN
179 CALL cgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
181 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
182 CALL cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
185 WRITE( nout, fmt = 9999 )
186 $ cmatnm, ia+k-1, ja+h, real( work( k ) ),
191 IF( myrow.EQ.icurrow )
193 icurrow = mod( icurrow+1, nprow )
194 CALL blacs_barrier( ictxt,
'All' )
198 DO 50 i = in+1, ia+m-1, desca( mb_ )
199 ib =
min( desca( mb_ ), ia+m-i )
200 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt )
THEN
201 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
203 WRITE( nout, fmt = 9999 )
205 $ real( a( ii+k+(jj+h-1)*lda ) ),
206 $ aimag( a( ii+k+(jj+h-1)*lda ) )
210 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol )
THEN
211 CALL cgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
212 $ lda, irprnt, icprnt )
213 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
214 CALL cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
217 WRITE( nout, fmt = 9999 )
218 $ cmatnm, i+k-1, ja+h, real( work( k ) ),
223 IF( myrow.EQ.icurrow )
225 icurrow = mod( icurrow+1, nprow )
226 CALL blacs_barrier( ictxt,
'All' )
233 IF( mycol.EQ.icurcol )
235 icurcol = mod( icurcol+1, npcol )
236 CALL blacs_barrier( ictxt,
'All' )
240 DO 130 j = jn+1, ja+n-1, desca( nb_ )
241 jb =
min( desca( nb_ ), ja+n-j )
243 in =
min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
245 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt )
THEN
246 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
248 WRITE( nout, fmt = 9999 )
250 $ real( a( ii+k+(jj+h-1)*lda ) ),
251 $ aimag( a( ii+k+(jj+h-1)*lda ) )
255 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol )
THEN
256 CALL cgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
257 $ lda, irprnt, icprnt )
258 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
259 CALL cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
262 WRITE( nout, fmt = 9999 )
263 $ cmatnm, ia+k-1, j+h, real( work( k ) ),
268 IF( myrow.EQ.icurrow )
270 icurrow = mod( icurrow+1, nprow )
271 CALL blacs_barrier( ictxt,
'All' )
275 DO 110 i = in+1, ia+m-1, desca( mb_ )
276 ib =
min( desca( mb_ ), ia+m-i )
277 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt )
THEN
278 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
280 WRITE( nout, fmt = 9999 )
282 $ real( a( ii+k+(jj+h-1)*lda ) ),
283 $ aimag( a( ii+k+(jj+h-1)*lda ) )
287 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol )
THEN
288 CALL cgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
289 $ lda, irprnt, icprnt )
290 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt )
THEN
291 CALL cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
294 WRITE( nout, fmt = 9999 )
295 $ cmatnm, i+k-1, j+h, real( work( k ) ),
300 IF( myrow.EQ.icurrow )
302 icurrow = mod( icurrow+1, nprow )
303 CALL blacs_barrier( ictxt,
'All' )
310 IF( mycol.EQ.icurcol )
312 icurcol = mod( icurcol+1, npcol )
313 CALL blacs_barrier( ictxt,
'All' )
317 9999
FORMAT(a,
'(',i6,
',',i6,
')=',e16.8,
'+i*(',e16.8,
')')