1 #include "Bdef.h"
2
3 #if (INTFACE == C_CALL)
Czgebr2d(int ConTxt,char * scope,char * top,int m,int n,double * A,int lda,int rsrc,int csrc)4 void Czgebr2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
5 int lda, int rsrc, int csrc)
6 #else
7 F_VOID_FUNC zgebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
8 double *A, int *lda, int *rsrc, int *csrc)
9 #endif
10 /*
11 * -- V1.1 BLACS routine --
12 * University of Tennessee, May 1, 1996
13 * Written by Clint Whaley.
14 *
15 * Purpose
16 * =======
17 * Broadcast/receive for general double complex arrays.
18 *
19 * Arguments
20 * =========
21 *
22 * ConTxt (input) Ptr to int
23 * Index into MyConTxts00 (my contexts array).
24 *
25 * SCOPE (input) Ptr to char
26 * Limit the scope of the operation.
27 * = 'R' : Operation is performed by a process row.
28 * = 'C' : Operation is performed by a process column.
29 * = 'A' : Operation is performed by all processes in grid.
30 *
31 * TOP (input) Ptr to char
32 * Controls fashion in which messages flow within the operation.
33 *
34 * M (input) Ptr to int
35 * The number of rows of the matrix A. M >= 0.
36 *
37 * N (input) Ptr to int
38 * The number of columns of the matrix A. N >= 0.
39 *
40 * A (output) Ptr to double complex two dimensional array
41 * The m by n matrix A. Fortran77 (column-major) storage
42 * assumed.
43 *
44 * LDA (input) Ptr to int
45 * The leading dimension of the array A. LDA >= M.
46 *
47 *
48 * RSRC (input) Ptr to int
49 * The process row of the source of the matrix.
50 *
51 * CSRC (input) Ptr to int
52 * The process column of the source of the matrix.
53 *
54 *
55 * ------------------------------------------------------------------------
56 */
57 {
58 void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
59 int *, int *);
60 int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
61 void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
62 void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
63 void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
64 void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
65 void BI_UpdateBuffs(BLACBUFF *);
66 BLACBUFF *BI_GetBuff(int);
67 int BI_BuffIsFree(BLACBUFF *, int);
68 MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
69 MPI_Datatype, int *);
70 void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
71 void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
72 void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
73
74 BLACSCONTEXT *ctxt;
75 BLACBUFF *bp=NULL;
76 SDRVPTR send;
77 MPI_Datatype MatTyp;
78 int length, src, tlda, error, one=1;
79 char ttop, tscope;
80 extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
81
82 MGetConTxt(Mpval(ConTxt), ctxt);
83 ttop = F2C_CharTrans(top);
84 ttop = Mlowcase(ttop);
85 tscope = F2C_CharTrans(scope);
86 tscope = Mlowcase(tscope);
87 #if (BlacsDebugLvl > 0)
88 BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m),
89 Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
90 #endif
91 /*
92 * If the user has set the default broadcast topology, use it instead of
93 * BLACS default
94 */
95 #ifdef DefBSTop
96 if (ttop == ' ') ttop = DefBSTop;
97 #endif
98 if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
99 else tlda = Mpval(m);
100
101 switch(tscope)
102 {
103 case 'r':
104 ctxt->scp = &ctxt->rscp;
105 src = Mpval(csrc);
106 break;
107 case 'c':
108 ctxt->scp = &ctxt->cscp;
109 src = Mpval(rsrc);
110 break;
111 case 'a':
112 ctxt->scp = &ctxt->ascp;
113 src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
114 break;
115 default:
116 BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
117 tscope);
118 }
119
120 MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
121 MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
122 /*
123 * If using default topology, use MPI native broadcast
124 */
125 if (ttop == ' ')
126 {
127 error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
128 error=BI_MPI_TYPE_FREE(&MatTyp);
129 if (BI_ActiveQ) BI_UpdateBuffs(NULL);
130 return;
131 }
132 /*
133 * If MPI handles non-contiguous buffering well, always use MPI data types
134 * instead of packing
135 */
136 #ifndef MpiBuffGood
137 /*
138 * If A is contiguous, receive and send directly to/from it
139 */
140 else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
141 {
142 #endif
143 send = BI_Ssend;
144 BI_AuxBuff.Buff = (char *) A;
145 BI_AuxBuff.dtype = MatTyp;
146 bp = &BI_AuxBuff;
147 #ifndef MpiBuffGood
148 }
149 /*
150 * If A is not contiguous, we receive message as packed so it can be
151 * forwarded without further system intervention
152 */
153 else
154 {
155 send = BI_Asend;
156 MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length);
157 bp = BI_GetBuff(length);
158 bp->N = length;
159 bp->dtype = MPI_PACKED;
160 #if ZeroByteTypeBug
161 if (MatTyp == MPI_BYTE)
162 {
163 send = BI_Ssend;
164 bp->N = 0;
165 bp->dtype = MPI_BYTE;
166 }
167 #endif
168 }
169 #endif
170
171 switch(ttop)
172 {
173 case 'h':
174 error = BI_HypBR(ctxt, bp, send, src);
175 if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
176 break;
177 case '1':
178 case '2':
179 case '3':
180 case '4':
181 case '5':
182 case '6':
183 case '7':
184 case '8':
185 case '9':
186 BI_TreeBR(ctxt, bp, send, src, ttop-47);
187 break;
188 case 't':
189 BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
190 break;
191 case 'i':
192 BI_IdringBR(ctxt, bp, send, src, 1);
193 break;
194 case 'd':
195 BI_IdringBR(ctxt, bp, send, src, -1);
196 break;
197 case 's':
198 BI_SringBR(ctxt, bp, send, src);
199 break;
200 case 'm':
201 BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
202 break;
203 case 'f':
204 BI_MpathBR(ctxt, bp, send, src, FULLCON);
205 break;
206 default :
207 BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
208 ttop);
209 }
210
211 /*
212 * If we buffered, unpack.
213 */
214 #ifndef MpiBuffGood
215 if (bp != &BI_AuxBuff)
216 {
217 BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
218 BI_UpdateBuffs(bp);
219 }
220 else
221 #endif
222 {
223 error=BI_MPI_TYPE_FREE(&MatTyp);
224 if (BI_ActiveQ) BI_UpdateBuffs(NULL);
225 }
226 }
227