ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pclaprnt.f
Go to the documentation of this file.
1  SUBROUTINE pclaprnt( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
2  $ CMATNM, NOUT, WORK )
3 *
4 * -- ScaLAPACK tools routine (version 1.7) --
5 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6 * and University of California, Berkeley.
7 * May 1, 1997
8 *
9 * .. Scalar Arguments ..
10  INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT
11 * ..
12 * .. Array Arguments ..
13  CHARACTER*(*) CMATNM
14  INTEGER DESCA( * )
15  COMPLEX A( * ), WORK( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PCLAPRNT prints to the standard output a distributed matrix sub( A )
22 * denoting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and
23 * printed by the process of coordinates (IRPRNT, ICPRNT).
24 *
25 * Notes
26 * =====
27 *
28 * Each global data object is described by an associated description
29 * vector. This vector stores the information required to establish
30 * the mapping between an object element and its corresponding process
31 * and memory location.
32 *
33 * Let A be a generic term for any 2D block cyclicly distributed array.
34 * Such a global array has an associated description vector DESCA.
35 * In the following comments, the character _ should be read as
36 * "of the global array".
37 *
38 * NOTATION STORED IN EXPLANATION
39 * --------------- -------------- --------------------------------------
40 * DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
41 * DTYPE_A = 1.
42 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
43 * the BLACS process grid A is distribu-
44 * ted over. The context itself is glo-
45 * bal, but the handle (the integer
46 * value) may vary.
47 * M_A (global) DESCA( M_ ) The number of rows in the global
48 * array A.
49 * N_A (global) DESCA( N_ ) The number of columns in the global
50 * array A.
51 * MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
52 * the rows of the array.
53 * NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
54 * the columns of the array.
55 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
56 * row of the array A is distributed.
57 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
58 * first column of the array A is
59 * distributed.
60 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
61 * array. LLD_A >= MAX(1,LOCr(M_A)).
62 *
63 * Let K be the number of rows or columns of a distributed matrix,
64 * and assume that its process grid has dimension p x q.
65 * LOCr( K ) denotes the number of elements of K that a process
66 * would receive if K were distributed over the p processes of its
67 * process column.
68 * Similarly, LOCc( K ) denotes the number of elements of K that a
69 * process would receive if K were distributed over the q processes of
70 * its process row.
71 * The values of LOCr() and LOCc() may be determined via a call to the
72 * ScaLAPACK tool function, NUMROC:
73 * LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
74 * LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
75 * An upper bound for these quantities may be computed by:
76 * LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
77 * LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
78 *
79 * Arguments
80 * =========
81 *
82 * M (global input) INTEGER
83 * The number of rows to be operated on i.e the number of rows
84 * of the distributed submatrix sub( A ). M >= 0.
85 *
86 * N (global input) INTEGER
87 * The number of columns to be operated on i.e the number of
88 * columns of the distributed submatrix sub( A ). N >= 0.
89 *
90 * A (local input) COMPLEX pointer into the local memory to a
91 * local array of dimension (LLD_A, LOCc(JA+N-1) ) containing
92 * the local pieces of the distributed matrix sub( A ).
93 *
94 * IA (global input) INTEGER
95 * The row index in the global array A indicating the first
96 * row of sub( A ).
97 *
98 * JA (global input) INTEGER
99 * The column index in the global array A indicating the
100 * first column of sub( A ).
101 *
102 * DESCA (global and local input) INTEGER array of dimension DLEN_.
103 * The array descriptor for the distributed matrix A.
104 *
105 * IRPRNT (global input) INTEGER
106 * The row index of the printing process.
107 *
108 * ICPRNT (global input) INTEGER
109 * The column index of the printing process.
110 *
111 * CMATNM (global input) CHARACTER*(*)
112 * Identifier of the distributed matrix to be printed.
113 *
114 * NOUT (global input) INTEGER
115 * The unit number for output file. NOUT = 6, ouput to screen,
116 * NOUT = 0, output to stderr.
117 *
118 * WORK (local workspace) COMPLEX
119 * Working array of minimum size equal to MB_A.
120 *
121 * =====================================================================
122 *
123 * .. Parameters ..
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 )
129 * ..
130 * .. Local Scalars ..
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
134 * ..
135 * .. External Subroutines ..
136  EXTERNAL blacs_barrier, blacs_gridinfo, infog2l,
137  $ cgerv2d, cgesd2d
138 * ..
139 * .. External Functions ..
140  INTEGER ICEIL
141  EXTERNAL iceil
142 * ..
143 * .. Intrinsic Functions ..
144  INTRINSIC aimag, min, real
145 * ..
146 * .. Executable Statements ..
147 *
148 * Get grid parameters
149 *
150  ictxt = desca( ctxt_ )
151  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
152 *
153  CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
154  $ iia, jja, iarow, iacol )
155  icurrow = iarow
156  icurcol = iacol
157  ii = iia
158  jj = jja
159  lda = desca( lld_ )
160 *
161 * Handle the first block of column separately
162 *
163  jn = min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
164  jb = jn-ja+1
165  DO 60 h = 0, jb-1
166  in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
167  ib = in-ia+1
168  IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
169  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
170  DO 10 k = 0, ib-1
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) )
175  10 CONTINUE
176  END IF
177  ELSE
178  IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
179  CALL cgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
180  $ irprnt, icprnt )
181  ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
182  CALL cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
183  $ icurrow, icurcol )
184  DO 20 k = 1, ib
185  WRITE( nout, fmt = 9999 )
186  $ cmatnm, ia+k-1, ja+h, real( work( k ) ),
187  $ aimag( work( k ) )
188  20 CONTINUE
189  END IF
190  END IF
191  IF( myrow.EQ.icurrow )
192  $ ii = ii + ib
193  icurrow = mod( icurrow+1, nprow )
194  CALL blacs_barrier( ictxt, 'All' )
195 *
196 * Loop over remaining block of rows
197 *
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
202  DO 30 k = 0, ib-1
203  WRITE( nout, fmt = 9999 )
204  $ cmatnm, i+k, ja+h,
205  $ real( a( ii+k+(jj+h-1)*lda ) ),
206  $ aimag( a( ii+k+(jj+h-1)*lda ) )
207  30 CONTINUE
208  END IF
209  ELSE
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_ ),
215  $ icurrow, icurcol )
216  DO 40 k = 1, ib
217  WRITE( nout, fmt = 9999 )
218  $ cmatnm, i+k-1, ja+h, real( work( k ) ),
219  $ aimag( work( k ) )
220  40 CONTINUE
221  END IF
222  END IF
223  IF( myrow.EQ.icurrow )
224  $ ii = ii + ib
225  icurrow = mod( icurrow+1, nprow )
226  CALL blacs_barrier( ictxt, 'All' )
227  50 CONTINUE
228 *
229  ii = iia
230  icurrow = iarow
231  60 CONTINUE
232 *
233  IF( mycol.EQ.icurcol )
234  $ jj = jj + jb
235  icurcol = mod( icurcol+1, npcol )
236  CALL blacs_barrier( ictxt, 'All' )
237 *
238 * Loop over remaining column blocks
239 *
240  DO 130 j = jn+1, ja+n-1, desca( nb_ )
241  jb = min( desca( nb_ ), ja+n-j )
242  DO 120 h = 0, jb-1
243  in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
244  ib = in-ia+1
245  IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
246  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
247  DO 70 k = 0, ib-1
248  WRITE( nout, fmt = 9999 )
249  $ cmatnm, ia+k, j+h,
250  $ real( a( ii+k+(jj+h-1)*lda ) ),
251  $ aimag( a( ii+k+(jj+h-1)*lda ) )
252  70 CONTINUE
253  END IF
254  ELSE
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_ ),
260  $ icurrow, icurcol )
261  DO 80 k = 1, ib
262  WRITE( nout, fmt = 9999 )
263  $ cmatnm, ia+k-1, j+h, real( work( k ) ),
264  $ aimag( work( k ) )
265  80 CONTINUE
266  END IF
267  END IF
268  IF( myrow.EQ.icurrow )
269  $ ii = ii + ib
270  icurrow = mod( icurrow+1, nprow )
271  CALL blacs_barrier( ictxt, 'All' )
272 *
273 * Loop over remaining block of rows
274 *
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
279  DO 90 k = 0, ib-1
280  WRITE( nout, fmt = 9999 )
281  $ cmatnm, i+k, j+h,
282  $ real( a( ii+k+(jj+h-1)*lda ) ),
283  $ aimag( a( ii+k+(jj+h-1)*lda ) )
284  90 CONTINUE
285  END IF
286  ELSE
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_ ),
292  $ icurrow, icurcol )
293  DO 100 k = 1, ib
294  WRITE( nout, fmt = 9999 )
295  $ cmatnm, i+k-1, j+h, real( work( k ) ),
296  $ aimag( work( k ) )
297  100 CONTINUE
298  END IF
299  END IF
300  IF( myrow.EQ.icurrow )
301  $ ii = ii + ib
302  icurrow = mod( icurrow+1, nprow )
303  CALL blacs_barrier( ictxt, 'All' )
304  110 CONTINUE
305 *
306  ii = iia
307  icurrow = iarow
308  120 CONTINUE
309 *
310  IF( mycol.EQ.icurcol )
311  $ jj = jj + jb
312  icurcol = mod( icurcol+1, npcol )
313  CALL blacs_barrier( ictxt, 'All' )
314 *
315  130 CONTINUE
316 *
317  9999 FORMAT(a,'(',i6,',',i6,')=',e16.8, '+i*(',e16.8, ')')
318 *
319  RETURN
320 *
321 * End of PCLAPRNT
322 *
323  END
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pclaprnt
subroutine pclaprnt(M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, CMATNM, NOUT, WORK)
Definition: pclaprnt.f:3
min
#define min(A, B)
Definition: pcgemr.c:181