1
2
3
4
5
6
7
8
9
10
11
12
13
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
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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
SUBROUTINE PDTREECOMB( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0,
$ SUBPTR )
*
* -- ScaLAPACK tools routine (version 1.7) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
* May 1, 1997
*
* .. Scalar Arguments ..
CHARACTER SCOPE
INTEGER CDEST0, ICTXT, N, RDEST0
* ..
* .. Array Arguments ..
DOUBLE PRECISION MINE( * )
* ..
* .. Subroutine Arguments ..
EXTERNAL SUBPTR
* ..
*
* Purpose
* =======
*
* PDTREECOMB does a 1-tree parallel combine operation on scalars,
* using the subroutine indicated by SUBPTR to perform the required
* computation.
*
* Arguments
* =========
*
* ICTXT (global input) INTEGER
* The BLACS context handle, indicating the global context of
* the operation. The context itself is global.
*
* SCOPE (global input) CHARACTER
* The scope of the operation: 'Rowwise', 'Columnwise', or
* 'All'.
*
* N (global input) INTEGER
* The number of elements in MINE. N = 1 for the norm-2
* computation and 2 for the sum of square.
*
* MINE (local input/global output) DOUBLE PRECISION array of
* dimension at least equal to N. The local data to use in the
* combine.
*
* RDEST0 (global input) INTEGER
* The process row to receive the answer. If RDEST0 = -1,
* every process in the scope gets the answer.
*
* CDEST0 (global input) INTEGER
* The process column to receive the answer. If CDEST0 = -1,
* every process in the scope gets the answer.
*
* SUBPTR (local input) Pointer to the subroutine to call to perform
* the required combine.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL BCAST, RSCOPE, CSCOPE
INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL,
$ MYROW, MYDIST, MYDIST2, NP, NPCOL, NPROW,
$ RMSSG, TCDEST, TRDEST
* ..
* .. Local Arrays ..
DOUBLE PRECISION HIS( 2 )
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, DGEBR2D, DGEBS2D,
$ DGERV2D, DGESD2D
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
* See if everyone wants the answer (need to broadcast the answer)
*
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
IF( BCAST ) THEN
TRDEST = 0
TCDEST = 0
ELSE
TRDEST = RDEST0
TCDEST = CDEST0
END IF
*
* Get grid parameters.
*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* Figure scope-dependant variables, or report illegal scope
*
RSCOPE = LSAME( SCOPE, 'R' )
CSCOPE = LSAME( SCOPE, 'C' )
*
IF( RSCOPE ) THEN
IF( BCAST ) THEN
TRDEST = MYROW
ELSE IF( MYROW.NE.TRDEST ) THEN
RETURN
END IF
NP = NPCOL
MYDIST = MOD( NPCOL + MYCOL - TCDEST, NPCOL )
ELSE IF( CSCOPE ) THEN
IF( BCAST ) THEN
TCDEST = MYCOL
ELSE IF( MYCOL.NE.TCDEST ) THEN
RETURN
END IF
NP = NPROW
MYDIST = MOD( NPROW + MYROW - TRDEST, NPROW )
ELSE IF( LSAME( SCOPE, 'A' ) ) THEN
NP = NPROW * NPCOL
IAM = MYROW*NPCOL + MYCOL
DEST = TRDEST*NPCOL + TCDEST
MYDIST = MOD( NP + IAM - DEST, NP )
ELSE
RETURN
END IF
*
IF( NP.LT.2 )
$ RETURN
*
MYDIST2 = MYDIST
RMSSG = MYROW
CMSSG = MYCOL
I = 1
*
10 CONTINUE
*
IF( MOD( MYDIST, 2 ).NE.0 ) THEN
*
* If I am process that sends information
*
DIST = I * ( MYDIST - MOD( MYDIST, 2 ) )
*
* Figure coordinates of dest of message
*
IF( RSCOPE ) THEN
CMSSG = MOD( TCDEST + DIST, NP )
ELSE IF( CSCOPE ) THEN
RMSSG = MOD( TRDEST + DIST, NP )
ELSE
CMSSG = MOD( DEST + DIST, NP )
RMSSG = CMSSG / NPCOL
CMSSG = MOD( CMSSG, NPCOL )
END IF
*
CALL DGESD2D( ICTXT, N, 1, MINE, N, RMSSG, CMSSG )
*
GO TO 20
*
ELSE
*
* If I am a process receiving information, figure coordinates
* of source of message
*
DIST = MYDIST2 + I
IF( RSCOPE ) THEN
CMSSG = MOD( TCDEST + DIST, NP )
HISDIST = MOD( NP + CMSSG - TCDEST, NP )
ELSE IF( CSCOPE ) THEN
RMSSG = MOD( TRDEST + DIST, NP )
HISDIST = MOD( NP + RMSSG - TRDEST, NP )
ELSE
CMSSG = MOD( DEST + DIST, NP )
RMSSG = CMSSG / NPCOL
CMSSG = MOD( CMSSG, NPCOL )
HISDIST = MOD( NP + RMSSG*NPCOL+CMSSG - DEST, NP )
END IF
*
IF( MYDIST2.LT.HISDIST ) THEN
*
* If I have anyone sending to me
*
CALL DGERV2D( ICTXT, N, 1, HIS, N, RMSSG, CMSSG )
CALL SUBPTR( MINE, HIS )
*
END IF
MYDIST = MYDIST / 2
*
END IF
I = I * 2
*
IF( I.LT.NP )
$ GO TO 10
*
20 CONTINUE
*
IF( BCAST ) THEN
IF( MYDIST2.EQ.0 ) THEN
CALL DGEBS2D( ICTXT, SCOPE, ' ', N, 1, MINE, N )
ELSE
CALL DGEBR2D( ICTXT, SCOPE, ' ', N, 1, MINE, N,
$ TRDEST, TCDEST )
END IF
END IF
*
RETURN
*
* End of PDTREECOMB
*
END
*
SUBROUTINE DCOMBAMAX( V1, V2 )
*
* -- ScaLAPACK tools routine (version 1.7) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
* May 1, 1997
*
* .. Array Arguments ..
DOUBLE PRECISION V1( 2 ), V2( 2 )
* ..
*
* Purpose
* =======
*
* DCOMBAMAX finds the element having max. absolute value as well
* as its corresponding globl index.
*
* Arguments
* =========
*
* V1 (local input/local output) DOUBLE PRECISION array of
* dimension 2. The first maximum absolute value element and
* its global index. V1(1) = AMAX, V1(2) = INDX.
*
* V2 (local input) DOUBLE PRECISION array of dimension 2.
* The second maximum absolute value element and its global
* index. V2(1) = AMAX, V2(2) = INDX.
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( ABS( V1( 1 ) ).LT.ABS( V2( 1 ) ) ) THEN
V1( 1 ) = V2( 1 )
V1( 2 ) = V2( 2 )
END IF
*
RETURN
*
* End of DCOMBAMAX
*
END
*
SUBROUTINE DCOMBSSQ( V1, V2 )
*
* -- ScaLAPACK tools routine (version 1.7) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
* May 1, 1997
*
* .. Array Arguments ..
DOUBLE PRECISION V1( 2 ), V2( 2 )
* ..
*
* Purpose
* =======
*
* DCOMBSSQ does a scaled sum of squares on two scalars.
*
* Arguments
* =========
*
* V1 (local input/local output) DOUBLE PRECISION array of
* dimension 2. The first scaled sum. V1(1) = SCALE,
* V1(2) = SUMSQ.
*
* V2 (local input) DOUBLE PRECISION array of dimension 2.
* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Executable Statements ..
*
IF( V1( 1 ).GE.V2( 1 ) ) THEN
IF( V1( 1 ).NE.ZERO )
$ V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 )
ELSE
V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 )
V1( 1 ) = V2( 1 )
END IF
*
RETURN
*
* End of DCOMBSSQ
*
END
*
SUBROUTINE DCOMBNRM2( X, Y )
*
* -- ScaLAPACK tools routine (version 1.7) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
* May 1, 1997
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y
* ..
*
* Purpose
* =======
*
* DCOMBNRM2 combines local norm 2 results, taking care not to cause
* unnecessary overflow.
*
* Arguments
* =========
*
* X (local input) DOUBLE PRECISION
* Y (local input) DOUBLE PRECISION
* X and Y specify the values x and y. X and Y are supposed to
* be >= 0.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, Z
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
W = MAX( X, Y )
Z = MIN( X, Y )
*
IF( Z.EQ.ZERO ) THEN
X = W
ELSE
X = W*SQRT( ONE+( Z / W )**2 )
END IF
*
RETURN
*
* End of DCOMBNRM2
*
END
|
