ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pstreecomb.f
Go to the documentation of this file.
1  SUBROUTINE pstreecomb( 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  REAL MINE( * )
15 * ..
16 * .. Subroutine Arguments ..
17  EXTERNAL subptr
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * PSTREECOMB 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) REAL 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  REAL HIS( 2 )
67 * ..
68 * .. External Subroutines ..
69  EXTERNAL blacs_gridinfo, sgebr2d, sgebs2d,
70  $ sgerv2d, sgesd2d
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 * See if everyone wants the answer (need to broadcast the answer)
83 *
84  bcast = ( ( rdest0.EQ.-1 ).OR.( cdest0.EQ.-1 ) )
85  IF( bcast ) THEN
86  trdest = 0
87  tcdest = 0
88  ELSE
89  trdest = rdest0
90  tcdest = cdest0
91  END IF
92 *
93 * Get grid parameters.
94 *
95  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
96 *
97 * Figure scope-dependant variables, or report illegal scope
98 *
99  rscope = lsame( scope, 'R' )
100  cscope = lsame( scope, 'C' )
101 *
102  IF( rscope ) THEN
103  IF( bcast ) THEN
104  trdest = myrow
105  ELSE IF( myrow.NE.trdest ) THEN
106  RETURN
107  END IF
108  np = npcol
109  mydist = mod( npcol + mycol - tcdest, npcol )
110  ELSE IF( cscope ) THEN
111  IF( bcast ) THEN
112  tcdest = mycol
113  ELSE IF( mycol.NE.tcdest ) THEN
114  RETURN
115  END IF
116  np = nprow
117  mydist = mod( nprow + myrow - trdest, nprow )
118  ELSE IF( lsame( scope, 'A' ) ) THEN
119  np = nprow * npcol
120  iam = myrow*npcol + mycol
121  dest = trdest*npcol + tcdest
122  mydist = mod( np + iam - dest, np )
123  ELSE
124  RETURN
125  END IF
126 *
127  IF( np.LT.2 )
128  $ RETURN
129 *
130  mydist2 = mydist
131  rmssg = myrow
132  cmssg = mycol
133  i = 1
134 *
135  10 CONTINUE
136 *
137  IF( mod( mydist, 2 ).NE.0 ) THEN
138 *
139 * If I am process that sends information
140 *
141  dist = i * ( mydist - mod( mydist, 2 ) )
142 *
143 * Figure coordinates of dest of message
144 *
145  IF( rscope ) THEN
146  cmssg = mod( tcdest + dist, np )
147  ELSE IF( cscope ) THEN
148  rmssg = mod( trdest + dist, np )
149  ELSE
150  cmssg = mod( dest + dist, np )
151  rmssg = cmssg / npcol
152  cmssg = mod( cmssg, npcol )
153  END IF
154 *
155  CALL sgesd2d( ictxt, n, 1, mine, n, rmssg, cmssg )
156 *
157  GO TO 20
158 *
159  ELSE
160 *
161 * If I am a process receiving information, figure coordinates
162 * of source of message
163 *
164  dist = mydist2 + i
165  IF( rscope ) THEN
166  cmssg = mod( tcdest + dist, np )
167  hisdist = mod( np + cmssg - tcdest, np )
168  ELSE IF( cscope ) THEN
169  rmssg = mod( trdest + dist, np )
170  hisdist = mod( np + rmssg - trdest, np )
171  ELSE
172  cmssg = mod( dest + dist, np )
173  rmssg = cmssg / npcol
174  cmssg = mod( cmssg, npcol )
175  hisdist = mod( np + rmssg*npcol+cmssg - dest, np )
176  END IF
177 *
178  IF( mydist2.LT.hisdist ) THEN
179 *
180 * If I have anyone sending to me
181 *
182  CALL sgerv2d( ictxt, n, 1, his, n, rmssg, cmssg )
183  CALL subptr( mine, his )
184 *
185  END IF
186  mydist = mydist / 2
187 *
188  END IF
189  i = i * 2
190 *
191  IF( i.LT.np )
192  $ GO TO 10
193 *
194  20 CONTINUE
195 *
196  IF( bcast ) THEN
197  IF( mydist2.EQ.0 ) THEN
198  CALL sgebs2d( ictxt, scope, ' ', n, 1, mine, n )
199  ELSE
200  CALL sgebr2d( ictxt, scope, ' ', n, 1, mine, n,
201  $ trdest, tcdest )
202  END IF
203  END IF
204 *
205  RETURN
206 *
207 * End of PSTREECOMB
208 *
209  END
210 *
211  SUBROUTINE scombamax( V1, V2 )
212 *
213 * -- ScaLAPACK tools routine (version 1.7) --
214 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
215 * and University of California, Berkeley.
216 * May 1, 1997
217 *
218 * .. Array Arguments ..
219  REAL V1( 2 ), V2( 2 )
220 * ..
221 *
222 * Purpose
223 * =======
224 *
225 * SCOMBAMAX finds the element having max. absolute value as well
226 * as its corresponding globl index.
227 *
228 * Arguments
229 * =========
230 *
231 * V1 (local input/local output) REAL array of
232 * dimension 2. The first maximum absolute value element and
233 * its global index. V1(1) = AMAX, V1(2) = INDX.
234 *
235 * V2 (local input) REAL array of dimension 2.
236 * The second maximum absolute value element and its global
237 * index. V2(1) = AMAX, V2(2) = INDX.
238 *
239 * =====================================================================
240 *
241 * .. Intrinsic Functions ..
242  INTRINSIC abs
243 * ..
244 * .. Executable Statements ..
245 *
246  IF( abs( v1( 1 ) ).LT.abs( v2( 1 ) ) ) THEN
247  v1( 1 ) = v2( 1 )
248  v1( 2 ) = v2( 2 )
249  END IF
250 *
251  RETURN
252 *
253 * End of SCOMBAMAX
254 *
255  END
256 *
257  SUBROUTINE scombssq( V1, V2 )
258 *
259 * -- ScaLAPACK tools routine (version 1.7) --
260 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
261 * and University of California, Berkeley.
262 * May 1, 1997
263 *
264 * .. Array Arguments ..
265  REAL V1( 2 ), V2( 2 )
266 * ..
267 *
268 * Purpose
269 * =======
270 *
271 * SCOMBSSQ does a scaled sum of squares on two scalars.
272 *
273 * Arguments
274 * =========
275 *
276 * V1 (local input/local output) REAL array of
277 * dimension 2. The first scaled sum. V1(1) = SCALE,
278 * V1(2) = SUMSQ.
279 *
280 * V2 (local input) REAL array of dimension 2.
281 * The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ.
282 *
283 * =====================================================================
284 *
285 * .. Parameters ..
286  REAL ZERO
287  parameter( zero = 0.0e+0 )
288 * ..
289 * .. Executable Statements ..
290 *
291  IF( v1( 1 ).GE.v2( 1 ) ) THEN
292  IF( v1( 1 ).NE.zero )
293  $ v1( 2 ) = v1( 2 ) + ( v2( 1 ) / v1( 1 ) )**2 * v2( 2 )
294  ELSE
295  v1( 2 ) = v2( 2 ) + ( v1( 1 ) / v2( 1 ) )**2 * v1( 2 )
296  v1( 1 ) = v2( 1 )
297  END IF
298 *
299  RETURN
300 *
301 * End of SCOMBSSQ
302 *
303  END
304 *
305  SUBROUTINE scombnrm2( X, Y )
306 *
307 * -- ScaLAPACK tools routine (version 1.7) --
308 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
309 * and University of California, Berkeley.
310 * May 1, 1997
311 *
312 * .. Scalar Arguments ..
313  REAL X, Y
314 * ..
315 *
316 * Purpose
317 * =======
318 *
319 * SCOMBNRM2 combines local norm 2 results, taking care not to cause
320 * unnecessary overflow.
321 *
322 * Arguments
323 * =========
324 *
325 * X (local input) REAL
326 * Y (local input) REAL
327 * X and Y specify the values x and y. X and Y are supposed to
328 * be >= 0.
329 *
330 * =====================================================================
331 *
332 * .. Parameters ..
333  REAL ONE, ZERO
334  parameter( one = 1.0e+0, zero = 0.0e+0 )
335 * ..
336 * .. Local Scalars ..
337  REAL W, Z
338 * ..
339 * .. Intrinsic Functions ..
340  INTRINSIC max, min, sqrt
341 * ..
342 * .. Executable Statements ..
343 *
344  w = max( x, y )
345  z = min( x, y )
346 *
347  IF( z.EQ.zero ) THEN
348  x = w
349  ELSE
350  x = w*sqrt( one+( z / w )**2 )
351  END IF
352 *
353  RETURN
354 *
355 * End of SCOMBNRM2
356 *
357  END
max
#define max(A, B)
Definition: pcgemr.c:180
scombamax
subroutine scombamax(V1, V2)
Definition: pstreecomb.f:212
pstreecomb
subroutine pstreecomb(ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, SUBPTR)
Definition: pstreecomb.f:3
scombssq
subroutine scombssq(V1, V2)
Definition: pstreecomb.f:258
scombnrm2
subroutine scombnrm2(X, Y)
Definition: pstreecomb.f:306
min
#define min(A, B)
Definition: pcgemr.c:181