OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzlaprnt.f
Go to the documentation of this file.
1 SUBROUTINE pzlaprnt( 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*16 A( * ), WORK( * )
16* ..
17*
18* Purpose
19* =======
20*
21* PZLAPRNT 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*16 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*16
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 $ zgerv2d, zgesd2d
138* ..
139* .. External Functions ..
140 INTEGER ICEIL
141 EXTERNAL iceil
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC dble, dimag, 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,
173 $ dble( a( ii+k+(jj+h-1)*lda ) ),
174 $ dimag( 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 zgesd2d( 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 zgerv2d( 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, dble( work( k ) ),
187 $ dimag( 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 $ dble( a( ii+k+(jj+h-1)*lda ) ),
206 $ dimag( 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 zgesd2d( 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 zgerv2d( 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, dble( work( k ) ),
219 $ dimag( 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 $ dble( a( ii+k+(jj+h-1)*lda ) ),
251 $ dimag( 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 zgesd2d( 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 zgerv2d( 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, dble( work( k ) ),
264 $ dimag( 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.EQ..AND..EQ. IF( ICURROWIRPRNT ICURCOLICPRNT ) THEN
278.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
279 DO 90 K = 0, IB-1
280 WRITE( NOUT, FMT = 9999 )
281 $ CMATNM, I+K, J+H,
282 $ DBLE( A( II+K+(JJ+H-1)*LDA ) ),
283 $ DIMAG( A( II+K+(JJ+H-1)*LDA ) )
284 90 CONTINUE
285 END IF
286 ELSE
287.EQ..AND..EQ. IF( MYROWICURROW MYCOLICURCOL ) THEN
288 CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
289 $ LDA, IRPRNT, ICPRNT )
290.EQ..AND..EQ. ELSE IF( MYROWIRPRNT MYCOLICPRNT ) THEN
291 CALL ZGERV2D( 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, DBLE( WORK( K ) ),
296 $ DIMAG( WORK( K ) )
297 100 CONTINUE
298 END IF
299 END IF
300.EQ. IF( MYROWICURROW )
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.EQ. IF( MYCOLICURCOL )
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,')=',D30.18, '+i*(',D30.18, ')')
318*
319 RETURN
320*
321* End of PZLAPRNT
322*
323 END
min
#define min(a, b)
Definition macros.h:20
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition mpi.f:937
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pzlaprnt
subroutine pzlaprnt(m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, work)
Definition pzlaprnt.f:3