SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
•All Classes Files Functions Variables Typedefs Macros

◆ pclaprnt()

subroutine pclaprnt ( integer  m,
integer  n,
complex, dimension( * )  a,
integer  ia,
integer  ja,
integer, dimension( * )  desca,
integer  irprnt,
integer  icprnt,
character*(*)  cmatnm,
integer  nout,
complex, dimension( * )  work 
)

Definition at line 1 of file pclaprnt.f.

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*
iceil
integer function iceil(inum, idenom)
Definition iceil.f:2
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition infog2l.f:3
min
#define min(A, B)
Definition pcgemr.c:181
Here is the call graph for this function:
Here is the caller graph for this function: