3
4
5
6
7
8
9
10 CHARACTER*1 DIREC, PIVROC, ROWCOL
11 INTEGER IA, IP, JA, JP, M, N
12
13
14 INTEGER DESCA( * ), DESCIP( * ), IPIV( * ), IWORK( * )
15 REAL A( * )
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
200 $ LLD_, MB_, M_, NB_, N_, RSRC_
201 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
202 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
203 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
204
205
206 LOGICAL ROWPVT
207 INTEGER I, ICTXT, ICURCOL, ICURROW, IIP, ITMP, IPT,
208 $ JJP, JPT, MYCOL, MYROW, NPCOL, NPROW
209
210
211 INTEGER DESCPT( DLEN_ )
212
213
214 EXTERNAL blacs_gridinfo, igebr2d, igebs2d,
216
217
218 LOGICAL LSAME
219 INTEGER NUMROC, INDXG2P
221
222
224
225
226
227
228
229 ictxt = desca( ctxt_ )
230 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
231 rowpvt =
lsame( rowcol,
'R' )
232
233
234
235 IF( rowpvt ) THEN
236 IF( m.LE.1 .OR. n.LT.1 )
237 $ RETURN
238
239
240
241 IF(
lsame( pivroc,
'C' ) )
THEN
242 CALL pslapv2( direc, rowcol, m, n, a, ia, ja, desca, ipiv,
243 $ ip, jp, descip )
244
245
246
247 ELSE
248
249
250
251
252 ipt = mod( jp-1, desca(mb_) )
253 descpt(m_) = m + ipt + nprow*desca(mb_)
254 descpt(n_) = 1
255 descpt(mb_) = desca(mb_)
256 descpt(nb_) = 1
257 descpt(rsrc_) =
indxg2p( ia, desca(mb_), ia, desca(rsrc_),
258 $ nprow )
259 descpt(csrc_) = mycol
260 descpt(ctxt_) = ictxt
261 descpt(lld_) =
numroc( descpt(m_), descpt(mb_), myrow,
262 $ descpt(rsrc_), nprow )
263 itmp =
numroc( descip(n_), descip(nb_), mycol,
264 $ descip(csrc_), npcol )
265 CALL infog2l( ip, jp-ipt, descip, nprow, npcol, myrow,
266 $ mycol, iip, jjp, icurrow, icurcol )
267 CALL pirow2col( ictxt, m+ipt, 1, descip(nb_), ipiv(jjp),
268 $ itmp, iwork, descpt(lld_), 0, icurcol,
269 $ descpt(rsrc_),
270 $ mycol, iwork(descpt(lld_)-descpt(mb_)+1) )
271
272
273
274 itmp = descpt(lld_) - descpt(mb_)
275 IF( mycol.EQ.0 ) THEN
276 CALL igebs2d( ictxt, 'Row', ' ', itmp, 1, iwork, itmp )
277 ELSE
278 CALL igebr2d( ictxt, 'Row', ' ', itmp, 1, iwork, itmp,
279 $ myrow, 0 )
280 END IF
281
282
283
284
285 ipt = ipt + 1
286 DO 10 i = 1, itmp
287 iwork(i) = iwork(i) - jp + ipt
288 10 CONTINUE
289 CALL pslapv2( direc, rowcol, m, n, a, ia, ja, desca, iwork,
290 $ ipt, 1, descpt )
291 END IF
292
293
294
295 ELSE
296 IF( m.LT.1 .OR. n.LE.1 )
297 $ RETURN
298
299
300
301 IF(
lsame( pivroc,
'R' ) )
THEN
302 CALL pslapv2( direc, rowcol, m, n, a, ia, ja, desca, ipiv,
303 $ ip, jp, descip )
304
305
306
307 ELSE
308
309
310
311
312 jpt = mod( ip-1, desca(nb_) )
313 descpt(m_) = 1
314 descpt(n_) = n + jpt + npcol*desca(nb_)
315 descpt(mb_) = 1
316 descpt(nb_) = desca(nb_)
317 descpt(rsrc_) = myrow
318 descpt(csrc_) =
indxg2p( ja, desca(nb_), ja, desca(csrc_),
319 $ npcol )
320 descpt(ctxt_) = ictxt
321 descpt(lld_) = 1
322 CALL infog2l( ip-jpt, jp, descip, nprow, npcol, myrow,
323 $ mycol, iip, jjp, icurrow, icurcol )
324 itmp =
numroc( n+jpt, descpt(nb_), mycol, descpt(csrc_),
325 $ npcol )
326 CALL picol2row( ictxt, n+jpt, 1, descip(mb_), ipiv(iip),
327 $ descip(lld_), iwork,
max(1, itmp), icurrow,
328 $ 0, 0, descpt(csrc_), iwork(itmp+1) )
329
330
331
332 IF( myrow.EQ.0 ) THEN
333 CALL igebs2d( ictxt, 'Column', ' ', itmp, 1, iwork,
334 $ itmp )
335 ELSE
336 CALL igebr2d( ictxt, 'Column', ' ', itmp, 1, iwork,
337 $ itmp, 0, mycol )
338 END IF
339
340
341
342
343 jpt = jpt + 1
344 DO 20 i = 1, itmp
345 iwork(i) = iwork(i) - ip + jpt
346 20 CONTINUE
347 CALL pslapv2( direc, rowcol, m, n, a, ia, ja, desca, iwork,
348 $ 1, jpt, descpt )
349 END IF
350 END IF
351
352 RETURN
353
354
355
integer function indxg2p(indxglob, nb, iproc, isrcproc, nprocs)
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine picol2row(ictxt, m, n, nb, vs, ldvs, vd, ldvd, rsrc, csrc, rdest, cdest, work)
subroutine pirow2col(ictxt, m, n, nb, vs, ldvs, vd, ldvd, rsrc, csrc, rdest, cdest, work)
subroutine pslapv2(direc, rowcol, m, n, a, ia, ja, desca, ipiv, ip, jp, descip)