2
3
4
5
6
7
8
9 INTEGER IA, JA, M, N
10
11
12 INTEGER DESCA( * )
13 REAL A( * ), TAU( * ), WORK( * )
14
15
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 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 REAL ONE, ZERO
130 parameter( one = 1.0e+0, zero = 0.0e+0 )
131
132
133 CHARACTER COLBTOP, ROWBTOP
134 INTEGER IACOL, IAROW, I, ICTXT, IIA, IPT, IPV, IPW,
135 $ IROFF, IV, J, JB, JJA, JL, JN, K, MP, MYCOL,
136 $ MYROW, NPCOL, NPROW
137
138
139 INTEGER DESCV( DLEN_ )
140
141
144 $ pb_topset
145
146
147 INTEGER ICEIL, INDXG2P, NUMROC
149
150
152
153
154
155
156
157 ictxt = desca( ctxt_ )
158 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
159
160 iroff = mod( ia-1, desca( mb_ ) )
161 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia, jja,
162 $ iarow, iacol )
163 mp =
numroc( m+iroff, desca( mb_ ), myrow, iarow, nprow )
164 ipv = 1
165 ipt = ipv + mp * desca( nb_ )
166 ipw = ipt + desca( nb_ ) * desca( nb_ )
167 CALL pb_topget( ictxt, 'Broadcast', 'Rowwise', rowbtop )
168 CALL pb_topget( ictxt, 'Broadcast', 'Columnwise', colbtop )
169 CALL pb_topset( ictxt, 'Broadcast', 'Rowwise', 'D-ring' )
170 CALL pb_topset( ictxt, 'Broadcast', 'Columnwise', ' ' )
171
173 jn =
min(
iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+k-1 )
174 jl =
max( ( (ja+k-2) / desca( nb_ ) ) * desca( nb_ ) + 1, ja )
175
176 CALL descset( descv, m+iroff, desca( nb_ ), desca( mb_ ),
177 $ desca( nb_ ), iarow,
indxg2p( jl, desca( nb_ ),
178 $ mycol, desca( csrc_ ), npcol ), ictxt,
180
181 DO 10 j = jl, jn+1, -desca( nb_ )
182 jb =
min( ja+k-j, desca( nb_ ) )
183 i = ia + j - ja
184 iv = 1 + j - ja + iroff
185
186
187
188 CALL pslarft(
'Forward',
'Columnwise', m-i+ia, jb, a, i, j,
189 $ desca, tau, work( ipt ), work( ipw ) )
190
191
192
193 CALL pslacpy(
'Lower', m-i+ia, jb, a, i, j, desca, work( ipv ),
194 $ iv, 1, descv )
195 CALL pslaset(
'Upper', m-i+ia, jb, zero, one, work( ipv ), iv,
196 $ 1, descv )
197
198
199
200
201 CALL pslaset(
'Lower', m-i+ia-1, jb, zero, zero, a, i+1, j,
202 $ desca )
203
204
205
206 CALL pslarfb(
'Left',
'No transpose',
'Forward',
'Columnwise',
207 $ m-i+ia, n-j+ja, jb, work( ipv ), iv, 1, descv,
208 $ work( ipt ), a, i, j, desca, work( ipw ) )
209
210 descv( csrc_ ) = mod( descv( csrc_ ) + npcol - 1, npcol )
211
212 10 CONTINUE
213
214
215
216 jb = jn - ja + 1
217
218
219
220 CALL pslarft(
'Forward',
'Columnwise', m, jb, a, ia, ja, desca,
221 $ tau, work( ipt ), work( ipw ) )
222
223
224
225 CALL pslacpy(
'Lower', m, jb, a, ia, ja, desca, work( ipv ),
226 $ iroff+1, 1, descv )
227 CALL pslaset(
'Upper', m, jb, zero, one, work, iroff+1, 1, descv )
228
229
230
231
232 CALL pslaset(
'Lower', m-1, jb, zero, zero, a, ia+1, ja, desca )
233
234
235
236 CALL pslarfb(
'Left',
'No transpose',
'Forward',
'Columnwise', m,
237 $ n, jb, work( ipv ), iroff+1, 1, descv, work( ipt ),
238 $ a, ia, ja, desca, work( ipw ) )
239
240 CALL pb_topset( ictxt, 'Broadcast', 'Rowwise', rowbtop )
241 CALL pb_topset( ictxt, 'Broadcast', 'Columnwise', colbtop )
242
243 RETURN
244
245
246
subroutine descset(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld)
integer function iceil(inum, idenom)
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 pslaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
subroutine pslacpy(uplo, m, n, a, ia, ja, desca, b, ib, jb, descb)
subroutine pslarfb(side, trans, direct, storev, m, n, k, v, iv, jv, descv, t, c, ic, jc, descc, work)
subroutine pslarft(direct, storev, n, k, v, iv, jv, descv, tau, t, work)