ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pitreecomb.f
Go to the documentation of this file.
1  SUBROUTINE pitreecomb( 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  INTEGER MINE( * )
15 * ..
16 * .. Subroutine Arguments ..
17  EXTERNAL subptr
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * PITREECOMB 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) @(typec) 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  INTEGER HIS( 2 )
67 * ..
68 * .. External Subroutines ..
69  EXTERNAL blacs_gridinfo, igebr2d, igebs2d,
70  $ igerv2d, igesd2d
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 igesd2d( 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 igerv2d( 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 igebs2d( ictxt, scope, ' ', n, 1, mine, n )
200  ELSE
201  CALL igebr2d( ictxt, scope, ' ', n, 1, mine, n,
202  $ trdest, tcdest )
203  END IF
204  END IF
205 *
206  RETURN
207 *
208 * End of PITREECOMB
209 *
210  END
pitreecomb
subroutine pitreecomb(ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, SUBPTR)
Definition: pitreecomb.f:3