3
4
5
6
7
8
9
10 INTEGER IA, IC, JA, JC, M, N
11 COMPLEX*16 ALPHA, BETA
12
13
14 INTEGER DESCA( * ), DESCC( * )
15 COMPLEX*16 A( * ), C( * )
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 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
138 $ LLD_, MB_, M_, NB_, N_, RSRC_
139 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
140 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
141 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
142 COMPLEX*16 ZERO, ONE
143 parameter( zero = ( 0.0d+0, 0.0d+0 ),
144 $ one = ( 1.0d+0, 0.0d+0 ) )
145
146
147 INTEGER I, IACOL, IAROW, ICCOL, ICOFF, ICROW, IIA,
148 $ IIC, IOFFA, IOFFC, IROFF, J, JJA, JJC, LDA,
149 $ LDC, MP, MYCOL, MYROW, NPCOL, NPROW, NQ
150
151
152 EXTERNAL blacs_gridinfo,
infog2l
153
154
155 INTEGER NUMROC
157
158
159
160
161
162 CALL blacs_gridinfo( desca(ctxt_), nprow, npcol, myrow, mycol )
163
164
165
166 IF( (m.EQ.0).OR.(n.EQ.0).OR.
167 $ ((alpha.EQ.zero).AND.(beta.EQ.one)) )
168 $ RETURN
169
170 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
171 $ iia, jja, iarow, iacol )
172 CALL infog2l( ic, jc, descc, nprow, npcol, myrow, mycol,
173 $ iic, jjc, icrow, iccol )
174
175 iroff = mod( ia-1, desca(mb_) )
176 icoff = mod( ja-1, desca(nb_) )
177 mp =
numroc( m+iroff, desca(mb_), myrow, iarow, nprow )
178 nq =
numroc( n+icoff, desca(nb_), mycol, iacol, npcol )
179 IF( myrow.EQ.iarow )
180 $ mp = mp-iroff
181 IF( mycol.EQ.iacol )
182 $ nq = nq-icoff
183 lda = desca(lld_)
184 ldc = descc(lld_)
185
186 IF( nq.EQ.1 ) THEN
187 IF( beta.EQ.zero ) THEN
188 IF( alpha.EQ.zero ) THEN
189 ioffc = iic + (jjc-1)*ldc
190 DO 10 i = ioffc, ioffc+mp-1
191 c( i ) = zero
192 10 CONTINUE
193 ELSE
194 ioffa = iia + (jja-1)*lda
195 ioffc = iic + (jjc-1)*ldc
196 DO 20 i = ioffc, ioffc+mp-1
197 c( i ) = alpha * a( ioffa )
198 ioffa = ioffa + 1
199 20 CONTINUE
200 END IF
201 ELSE
202 IF( alpha.EQ.one ) THEN
203 IF( beta.EQ.one ) THEN
204 ioffa = iia + (jja-1)*lda
205 ioffc = iic + (jjc-1)*ldc
206 DO 30 i = ioffc, ioffc+mp-1
207 c( i ) = c( i ) + a( ioffa )
208 ioffa = ioffa + 1
209 30 CONTINUE
210 ELSE
211 ioffa = iia + (jja-1)*lda
212 ioffc = iic + (jjc-1)*ldc
213 DO 40 i = ioffc, ioffc+mp-1
214 c( i ) = beta * c( i ) + a( ioffa )
215 ioffa = ioffa + 1
216 40 CONTINUE
217 END IF
218 ELSE IF( beta.EQ.one ) THEN
219 ioffa = iia + (jja-1)*lda
220 ioffc = iic + (jjc-1)*ldc
221 DO 50 i = ioffc, ioffc+mp-1
222 c( i ) = c( i ) + alpha * a( ioffa )
223 ioffa = ioffa + 1
224 50 CONTINUE
225 ELSE
226 ioffa = iia + (jja-1)*lda
227 ioffc = iic + (jjc-1)*ldc
228 DO 60 i = ioffc, ioffc+mp-1
229 c( i ) = beta * c( i ) + alpha * a( ioffa )
230 ioffa = ioffa + 1
231 60 CONTINUE
232 END IF
233 END IF
234 ELSE
235 IF( beta.EQ.zero ) THEN
236 IF( alpha.EQ.zero ) THEN
237 ioffc = iic+(jjc-1)*ldc
238 DO 80 j = 1, nq
239 DO 70 i = ioffc, ioffc+mp-1
240 c( i ) = zero
241 70 CONTINUE
242 ioffc = ioffc + ldc
243 80 CONTINUE
244 ELSE
245 ioffa = iia+(jja-1)*lda
246 ioffc = iic+(jjc-1)*ldc
247 DO 100 j = 1, nq
248 DO 90 i = ioffc, ioffc+mp-1
249 c( i ) = alpha * a( ioffa )
250 ioffa = ioffa + 1
251 90 CONTINUE
252 ioffa = ioffa + lda - mp
253 ioffc = ioffc + ldc
254 100 CONTINUE
255 END IF
256 ELSE
257 IF( alpha.EQ.one ) THEN
258 IF( beta.EQ.one ) THEN
259 ioffa = iia+(jja-1)*lda
260 ioffc = iic+(jjc-1)*ldc
261 DO 120 j = 1, nq
262 DO 110 i = ioffc, ioffc+mp-1
263 c( i ) = c( i ) + a( ioffa )
264 ioffa = ioffa + 1
265 110 CONTINUE
266 ioffa = ioffa + lda - mp
267 ioffc = ioffc + ldc
268 120 CONTINUE
269 ELSE
270 ioffa = iia+(jja-1)*lda
271 ioffc = iic+(jjc-1)*ldc
272 DO 140 j = 1, nq
273 DO 130 i = ioffc, ioffc+mp-1
274 c( i ) = beta * c( i ) + a( ioffa )
275 ioffa = ioffa + 1
276 130 CONTINUE
277 ioffa = ioffa + lda - mp
278 ioffc = ioffc + ldc
279 140 CONTINUE
280 END IF
281 ELSE IF( beta.EQ.one ) THEN
282 ioffa = iia+(jja-1)*lda
283 ioffc = iic+(jjc-1)*ldc
284 DO 160 j = 1, nq
285 DO 150 i = ioffc, ioffc+mp-1
286 c( i ) = c( i ) + alpha * a( ioffa )
287 ioffa = ioffa + 1
288 150 CONTINUE
289 ioffa = ioffa + lda - mp
290 ioffc = ioffc + ldc
291 160 CONTINUE
292 ELSE
293 ioffa = iia+(jja-1)*lda
294 ioffc = iic+(jjc-1)*ldc
295 DO 180 j = 1, nq
296 DO 170 i = ioffc, ioffc+mp-1
297 c( i ) = beta * c( i ) + alpha * a( ioffa )
298 ioffa = ioffa + 1
299 170 CONTINUE
300 ioffa = ioffa + lda - mp
301 ioffc = ioffc + ldc
302 180 CONTINUE
303 END IF
304 END IF
305 END IF
306
307 RETURN
308
309
310
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
integer function numroc(n, nb, iproc, isrcproc, nprocs)