ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pdtreecomb.f
Go to the documentation of this file.
1  SUBROUTINE pdtreecomb( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0,
2  $ SUBPTR )
3 *
4 * -- ScaLAPACK tools routine (version 1.7) --
5 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6 * and University of California, Berkeley.
7 * May 1, 1997
8 *
9 * .. Scalar Arguments ..
10  CHARACTER SCOPE
11  INTEGER CDEST0, ICTXT, N, RDEST0
12 * ..
13 * .. Array Arguments ..
14  DOUBLE PRECISION MINE( * )
15 * ..
16 * .. Subroutine Arguments ..
17  EXTERNAL subptr
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * PDTREECOMB does a 1-tree parallel combine operation on scalars,
24 * using the subroutine indicated by SUBPTR to perform the required
25 * computation.
26 *
27 * Arguments
28 * =========
29 *
30 * ICTXT (global input) INTEGER
31 * The BLACS context handle, indicating the global context of
32 * the operation. The context itself is global.
33 *
34 * SCOPE (global input) CHARACTER
35 * The scope of the operation: 'Rowwise', 'Columnwise', or
36 * 'All'.
37 *
38 * N (global input) INTEGER
39 * The number of elements in MINE. N = 1 for the norm-2
40 * computation and 2 for the sum of square.
41 *
42 * MINE (local input/global output) DOUBLE PRECISION array of
43 * dimension at least equal to N. The local data to use in the
44 * combine.
45 *
46 * RDEST0 (global input) INTEGER
47 * The process row to receive the answer. If RDEST0 = -1,
48 * every process in the scope gets the answer.
49 *
50 * CDEST0 (global input) INTEGER
51 * The process column to receive the answer. If CDEST0 = -1,
52 * every process in the scope gets the answer.
53 *
54 * SUBPTR (local input) Pointer to the subroutine to call to perform
55 * the required combine.
56 *
57 * =====================================================================
58 *
59 * .. Local Scalars ..
60  LOGICAL BCAST, RSCOPE, CSCOPE
61  INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL,
62  $ myrow, mydist, mydist2, np, npcol, nprow,
63  $ rmssg, tcdest, trdest
64 * ..
65 * .. Local Arrays ..
66  DOUBLE PRECISION HIS( 2 )
67 * ..
68 * .. External Subroutines ..
69  EXTERNAL blacs_gridinfo, dgebr2d, dgebs2d,
70  $ dgerv2d, dgesd2d
71 * ..
72 * .. External Functions ..
73  LOGICAL LSAME
74  EXTERNAL lsame
75 * ..
76 * .. Intrinsic Functions ..
77  INTRINSIC mod
78 * ..
79 * .. Executable Statements ..
80 *
81  dest = 0
82 *
83 * See if everyone wants the answer (need to broadcast the answer)
84 *
85  bcast = ( ( rdest0.EQ.-1 ).OR.( cdest0.EQ.-1 ) )
86  IF( bcast ) THEN
87  trdest = 0
88  tcdest = 0
89  ELSE
90  trdest = rdest0
91  tcdest = cdest0
92  END IF
93 *
94 * Get grid parameters.
95 *
96  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
97 *
98 * Figure scope-dependant variables, or report illegal scope
99 *
100  rscope = lsame( scope, 'R' )
101  cscope = lsame( scope, 'C' )
102 *
103  IF( rscope ) THEN
104  IF( bcast ) THEN
105  trdest = myrow
106  ELSE IF( myrow.NE.trdest ) THEN
107  RETURN
108  END IF
109  np = npcol
110  mydist = mod( npcol + mycol - tcdest, npcol )
111  ELSE IF( cscope ) THEN
112  IF( bcast ) THEN
113  tcdest = mycol
114  ELSE IF( mycol.NE.tcdest ) THEN
115  RETURN
116  END IF
117  np = nprow
118  mydist = mod( nprow + myrow - trdest, nprow )
119  ELSE IF( lsame( scope, 'A' ) ) THEN
120  np = nprow * npcol
121  iam = myrow*npcol + mycol
122  dest = trdest*npcol + tcdest
123  mydist = mod( np + iam - dest, np )
124  ELSE
125  RETURN
126  END IF
127 *
128  IF( np.LT.2 )
129  $ RETURN
130 *
131  mydist2 = mydist
132  rmssg = myrow
133  cmssg = mycol
134  i = 1
135 *
136  10 CONTINUE
137 *
138  IF( mod( mydist, 2 ).NE.0 ) THEN
139 *
140 * If I am process that sends information
141 *
142  dist = i * ( mydist - mod( mydist, 2 ) )
143 *
144 * Figure coordinates of dest of message
145 *
146  IF( rscope ) THEN
147  cmssg = mod( tcdest + dist, np )
148  ELSE IF( cscope ) THEN
149  rmssg = mod( trdest + dist, np )
150  ELSE
151  cmssg = mod( dest + dist, np )
152  rmssg = cmssg / npcol
153  cmssg = mod( cmssg, npcol )
154  END IF
155 *
156  CALL dgesd2d( ictxt, n, 1, mine, n, rmssg, cmssg )
157 *
158  GO TO 20
159 *
160  ELSE
161 *
162 * If I am a process receiving information, figure coordinates
163 * of source of message
164 *
165  dist = mydist2 + i
166  IF( rscope ) THEN
167  cmssg = mod( tcdest + dist, np )
168  hisdist = mod( np + cmssg - tcdest, np )
169  ELSE IF( cscope ) THEN
170  rmssg = mod( trdest + dist, np )
171  hisdist = mod( np + rmssg - trdest, np )
172  ELSE
173  cmssg = mod( dest + dist, np )
174  rmssg = cmssg / npcol
175  cmssg = mod( cmssg, npcol )
176  hisdist = mod( np + rmssg*npcol+cmssg - dest, np )
177  END IF
178 *
179  IF( mydist2.LT.hisdist ) THEN
180 *
181 * If I have anyone sending to me
182 *
183  CALL dgerv2d( ictxt, n, 1, his, n, rmssg, cmssg )
184  CALL subptr( mine, his )
185 *
186  END IF
187  mydist = mydist / 2
188 *
189  END IF
190  i = i * 2
191 *
192  IF( i.LT.np )
193  $ GO TO 10
194 *
195  20 CONTINUE
196 *
197  IF( bcast ) THEN
198  IF( mydist2.EQ.0 ) THEN
199  CALL dgebs2d( ictxt, scope, ' ', n, 1, mine, n )
200  ELSE
201  CALL dgebr2d( ictxt, scope, ' ', n, 1, mine, n,
202  $ trdest, tcdest )
203  END IF
204  END IF
205 *
206  RETURN
207 *
208 * End of PDTREECOMB
209 *
210  END
211 *
212  SUBROUTINE dcombamax( V1, V2 )
213 *
214 * -- ScaLAPACK tools routine (version 1.7) --
215 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
216 * and University of California, Berkeley.
217 * May 1, 1997
218 *
219 * .. Array Arguments ..
220  DOUBLE PRECISION V1( 2 ), V2( 2 )
221 * ..
222 *
223 * Purpose
224 * =======
225 *
226 * DCOMBAMAX finds the element having max. absolute value as well
227 * as its corresponding globl index.
228 *
229 * Arguments
230 * =========
231 *
232 * V1 (local input/local output) DOUBLE PRECISION array of
233 * dimension 2. The first maximum absolute value element and
234 * its global index. V1(1) = AMAX, V1(2) = INDX.
235 *
236 * V2 (local input) DOUBLE PRECISION array of dimension 2.
237 * The second maximum absolute value element and its global
238 * index. V2(1) = AMAX, V2(2) = INDX.
239 *
240 * =====================================================================
241 *
242 * .. Intrinsic Functions ..
243  INTRINSIC abs
244 * ..
245 * .. Executable Statements ..
246 *
247  IF( abs( v1( 1 ) ).LT.abs( v2( 1 ) ) ) THEN
248  v1( 1 ) = v2( 1 )
249  v1( 2 ) = v2( 2 )
250  END IF
251 *
252  RETURN
253 *
254 * End of DCOMBAMAX
255 *
256  END
257 *
258  SUBROUTINE dcombssq( V1, V2 )
259 *
260 * -- ScaLAPACK tools routine (version 1.7) --
261 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
262 * and University of California, Berkeley.
263 * May 1, 1997
264 *
265 * .. Array Arguments ..
266  DOUBLE PRECISION V1( 2 ), V2( 2 )
267 * ..
268 *
269 * Purpose
270 * =======
271 *
272 * DCOMBSSQ does a scaled sum of squares on two scalars.
273 *
274 * Arguments
275 * =========
276 *
277 * V1 (local input/local output) DOUBLE PRECISION array of
278 * dimension 2. The first scaled sum. V1(1) = SCALE,
279 * V1(2) = SUMSQ.
280 *
281 * V2 (local input) DOUBLE PRECISION array of dimension 2.
282 * The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ.
283 *
284 * =====================================================================
285 *
286 * .. Parameters ..
287  DOUBLE PRECISION ZERO
288  parameter( zero = 0.0d+0 )
289 * ..
290 * .. Executable Statements ..
291 *
292  IF( v1( 1 ).GE.v2( 1 ) ) THEN
293  IF( v1( 1 ).NE.zero )
294  $ v1( 2 ) = v1( 2 ) + ( v2( 1 ) / v1( 1 ) )**2 * v2( 2 )
295  ELSE
296  v1( 2 ) = v2( 2 ) + ( v1( 1 ) / v2( 1 ) )**2 * v1( 2 )
297  v1( 1 ) = v2( 1 )
298  END IF
299 *
300  RETURN
301 *
302 * End of DCOMBSSQ
303 *
304  END
305 *
306  SUBROUTINE dcombnrm2( X, Y )
307 *
308 * -- ScaLAPACK tools routine (version 1.7) --
309 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
310 * and University of California, Berkeley.
311 * May 1, 1997
312 *
313 * .. Scalar Arguments ..
314  DOUBLE PRECISION X, Y
315 * ..
316 *
317 * Purpose
318 * =======
319 *
320 * DCOMBNRM2 combines local norm 2 results, taking care not to cause
321 * unnecessary overflow.
322 *
323 * Arguments
324 * =========
325 *
326 * X (local input) DOUBLE PRECISION
327 * Y (local input) DOUBLE PRECISION
328 * X and Y specify the values x and y. X and Y are supposed to
329 * be >= 0.
330 *
331 * =====================================================================
332 *
333 * .. Parameters ..
334  DOUBLE PRECISION ONE, ZERO
335  parameter( one = 1.0d+0, zero = 0.0d+0 )
336 * ..
337 * .. Local Scalars ..
338  DOUBLE PRECISION W, Z
339 * ..
340 * .. Intrinsic Functions ..
341  INTRINSIC max, min, sqrt
342 * ..
343 * .. Executable Statements ..
344 *
345  w = max( x, y )
346  z = min( x, y )
347 *
348  IF( z.EQ.zero ) THEN
349  x = w
350  ELSE
351  x = w*sqrt( one+( z / w )**2 )
352  END IF
353 *
354  RETURN
355 *
356 * End of DCOMBNRM2
357 *
358  END
max
#define max(A, B)
Definition: pcgemr.c:180
pdtreecomb
subroutine pdtreecomb(ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, SUBPTR)
Definition: pdtreecomb.f:3
dcombssq
subroutine dcombssq(V1, V2)
Definition: pdtreecomb.f:259
dcombamax
subroutine dcombamax(V1, V2)
Definition: pdtreecomb.f:213
dcombnrm2
subroutine dcombnrm2(X, Y)
Definition: pdtreecomb.f:307
min
#define min(A, B)
Definition: pcgemr.c:181