ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pslaprnt.f
Go to the documentation of this file.
1  SUBROUTINE pslaprnt( 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  REAL A( * ), WORK( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PSLAPRNT 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) REAL 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) REAL
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  $ sgerv2d, sgesd2d
138 * ..
139 * .. External Functions ..
140  INTEGER ICEIL
141  EXTERNAL iceil
142 * ..
143 * .. Intrinsic Functions ..
144  INTRINSIC min
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, a( ii+k+(jj+h-1)*lda )
173  10 CONTINUE
174  END IF
175  ELSE
176  IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
177  CALL sgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
178  $ irprnt, icprnt )
179  ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
180  CALL sgerv2d( ictxt, ib, 1, work, desca( mb_ ),
181  $ icurrow, icurcol )
182  DO 20 k = 1, ib
183  WRITE( nout, fmt = 9999 )
184  $ cmatnm, ia+k-1, ja+h, work( k )
185  20 CONTINUE
186  END IF
187  END IF
188  IF( myrow.EQ.icurrow )
189  $ ii = ii + ib
190  icurrow = mod( icurrow+1, nprow )
191  CALL blacs_barrier( ictxt, 'All' )
192 *
193 * Loop over remaining block of rows
194 *
195  DO 50 i = in+1, ia+m-1, desca( mb_ )
196  ib = min( desca( mb_ ), ia+m-i )
197  IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
198  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
199  DO 30 k = 0, ib-1
200  WRITE( nout, fmt = 9999 )
201  $ cmatnm, i+k, ja+h, a( ii+k+(jj+h-1)*lda )
202  30 CONTINUE
203  END IF
204  ELSE
205  IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
206  CALL sgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
207  $ lda, irprnt, icprnt )
208  ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
209  CALL sgerv2d( ictxt, ib, 1, work, desca( mb_ ),
210  $ icurrow, icurcol )
211  DO 40 k = 1, ib
212  WRITE( nout, fmt = 9999 )
213  $ cmatnm, i+k-1, ja+h, work( k )
214  40 CONTINUE
215  END IF
216  END IF
217  IF( myrow.EQ.icurrow )
218  $ ii = ii + ib
219  icurrow = mod( icurrow+1, nprow )
220  CALL blacs_barrier( ictxt, 'All' )
221  50 CONTINUE
222 *
223  ii = iia
224  icurrow = iarow
225  60 CONTINUE
226 *
227  IF( mycol.EQ.icurcol )
228  $ jj = jj + jb
229  icurcol = mod( icurcol+1, npcol )
230  CALL blacs_barrier( ictxt, 'All' )
231 *
232 * Loop over remaining column blocks
233 *
234  DO 130 j = jn+1, ja+n-1, desca( nb_ )
235  jb = min( desca( nb_ ), ja+n-j )
236  DO 120 h = 0, jb-1
237  in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
238  ib = in-ia+1
239  IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
240  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
241  DO 70 k = 0, ib-1
242  WRITE( nout, fmt = 9999 )
243  $ cmatnm, ia+k, j+h, a( ii+k+(jj+h-1)*lda )
244  70 CONTINUE
245  END IF
246  ELSE
247  IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
248  CALL sgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
249  $ lda, irprnt, icprnt )
250  ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
251  CALL sgerv2d( ictxt, ib, 1, work, desca( mb_ ),
252  $ icurrow, icurcol )
253  DO 80 k = 1, ib
254  WRITE( nout, fmt = 9999 )
255  $ cmatnm, ia+k-1, j+h, work( k )
256  80 CONTINUE
257  END IF
258  END IF
259  IF( myrow.EQ.icurrow )
260  $ ii = ii + ib
261  icurrow = mod( icurrow+1, nprow )
262  CALL blacs_barrier( ictxt, 'All' )
263 *
264 * Loop over remaining block of rows
265 *
266  DO 110 i = in+1, ia+m-1, desca( mb_ )
267  ib = min( desca( mb_ ), ia+m-i )
268  IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
269  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
270  DO 90 k = 0, ib-1
271  WRITE( nout, fmt = 9999 )
272  $ cmatnm, i+k, j+h, a( ii+k+(jj+h-1)*lda )
273  90 CONTINUE
274  END IF
275  ELSE
276  IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
277  CALL sgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
278  $ lda, irprnt, icprnt )
279  ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
280  CALL sgerv2d( ictxt, ib, 1, work, desca( mb_ ),
281  $ icurrow, icurcol )
282  DO 100 k = 1, ib
283  WRITE( nout, fmt = 9999 )
284  $ cmatnm, i+k-1, j+h, work( k )
285  100 CONTINUE
286  END IF
287  END IF
288  IF( myrow.EQ.icurrow )
289  $ ii = ii + ib
290  icurrow = mod( icurrow+1, nprow )
291  CALL blacs_barrier( ictxt, 'All' )
292  110 CONTINUE
293 *
294  ii = iia
295  icurrow = iarow
296  120 CONTINUE
297 *
298  IF( mycol.EQ.icurcol )
299  $ jj = jj + jb
300  icurcol = mod( icurcol+1, npcol )
301  CALL blacs_barrier( ictxt, 'All' )
302 *
303  130 CONTINUE
304 *
305  9999 FORMAT(a,'(',i6,',',i6,')=',e16.8)
306 *
307  RETURN
308 *
309 * End of PSLAPRNT
310 *
311  END
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pslaprnt
subroutine pslaprnt(M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, CMATNM, NOUT, WORK)
Definition: pslaprnt.f:3
min
#define min(A, B)
Definition: pcgemr.c:181