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