xref: /petsc/src/mat/impls/baij/mpi/baijov.c (revision 3a40ed3dce77c081171d005ae1a6ff4bb9d13b6f)
1 #ifdef PETSC_RCS_HEADER
2 static char vcid[] = "$Id: baijov.c,v 1.25 1997/10/06 16:24:17 balay Exp bsmith $";
3 #endif
4 /*
5    Routines to compute overlapping regions of a parallel MPI matrix
6   and to find submatrices that were shared across processors.
7 */
8 #include "src/mat/impls/baij/mpi/mpibaij.h"
9 #include "src/inline/bitarray.h"
10 
11 static int MatIncreaseOverlap_MPIBAIJ_Once(Mat, int, IS *);
12 static int MatIncreaseOverlap_MPIBAIJ_Local(Mat , int , char **,int*, int**);
13 static int MatIncreaseOverlap_MPIBAIJ_Receive(Mat , int, int **, int**, int* );
14 extern int MatGetRow_MPIBAIJ(Mat,int,int*,int**,Scalar**);
15 extern int MatRestoreRow_MPIBAIJ(Mat,int,int*,int**,Scalar**);
16 
17 
18 #undef __FUNC__
19 #define __FUNC__ "MatCompressIndicesGeneral_MPIBAIJ"
20 static int MatCompressIndicesGeneral_MPIBAIJ(Mat C, int imax, IS *is_in, IS *is_out)
21 {
22   Mat_MPIBAIJ  *baij = (Mat_MPIBAIJ *) C->data;
23   int          ierr,isz,bs = baij->bs,Nbs,n,i,j,*idx,*nidx,ival;
24   BT           table;
25 
26   PetscFunctionBegin;
27   Nbs   = baij->Nbs;
28   nidx  = (int *) PetscMalloc((Nbs+1)*sizeof(int)); CHKPTRQ(nidx);
29   ierr  = BTCreate(Nbs,table); CHKERRQ(ierr);
30 
31   for (i=0; i<imax; i++) {
32     isz  = 0;
33     BTMemzero(Nbs,table);
34     ierr = ISGetIndices(is_in[i],&idx);  CHKERRQ(ierr);
35     ierr = ISGetSize(is_in[i],&n);  CHKERRQ(ierr);
36     for (j=0; j<n ; j++) {
37       ival = idx[j]/bs; /* convert the indices into block indices */
38       if (ival>Nbs) SETERRQ(1,0,"index greater than mat-dim");
39       if(!BTLookupSet(table, ival)) { nidx[isz++] = ival;}
40     }
41     ierr = ISRestoreIndices(is_in[i],&idx);  CHKERRQ(ierr);
42     ierr = ISCreateGeneral(PETSC_COMM_SELF, isz, nidx, (is_out+i)); CHKERRQ(ierr);
43   }
44   BTDestroy(table);
45   PetscFree(nidx);
46   PetscFunctionReturn(0);
47 }
48 
49 #undef __FUNC__
50 #define __FUNC__ "MatCompressIndicesSorted_MPIBAIJ"
51 static int MatCompressIndicesSorted_MPIBAIJ(Mat C, int imax, IS *is_in, IS *is_out)
52 {
53   Mat_MPIBAIJ  *baij = (Mat_MPIBAIJ *) C->data;
54   int          ierr,bs=baij->bs,i,j,k,val,n,*idx,*nidx,Nbs=baij->Nbs,*idx_local;
55   PetscTruth   flg;
56 
57   PetscFunctionBegin;
58   for (i=0; i<imax; i++) {
59     ierr = ISSorted(is_in[i],&flg); CHKERRQ(ierr);
60     if (!flg) SETERRQ(1,0,"Indices are not sorted");
61   }
62   nidx  = (int *) PetscMalloc((Nbs+1)*sizeof(int)); CHKPTRQ(nidx);
63   /* Now check if the indices are in block order */
64   for (i=0; i<imax; i++) {
65     ierr = ISGetIndices(is_in[i],&idx);  CHKERRQ(ierr);
66     ierr = ISGetSize(is_in[i],&n);  CHKERRQ(ierr);
67     if ( n%bs !=0 ) SETERRA(1,0,"Indices are not block ordered");
68 
69     n = n/bs; /* The reduced index size */
70     idx_local = idx;
71     for (j=0; j<n ; j++) {
72       val = idx_local[0];
73       if(val%bs != 0) SETERRA(1,0,"Indices are not block ordered");
74       for (k=0; k<bs; k++) {
75         if ( val+k != idx_local[k]) SETERRA(1,0,"Indices are not block ordered");
76       }
77       nidx[j] = val/bs;
78       idx_local +=bs;
79     }
80     ierr = ISRestoreIndices(is_in[i],&idx);  CHKERRQ(ierr);
81     ierr = ISCreateGeneral(PETSC_COMM_SELF,n,nidx,(is_out+i)); CHKERRQ(ierr);
82   }
83   PetscFree(nidx);
84   PetscFunctionReturn(0);
85 }
86 
87 #undef __FUNC__
88 #define __FUNC__ "MatExpandIndices_MPIBAIJ"
89 static int MatExpandIndices_MPIBAIJ(Mat C, int imax, IS *is_in, IS *is_out)
90 {
91   Mat_MPIBAIJ  *baij = (Mat_MPIBAIJ *) C->data;
92   int          ierr,bs = baij->bs,Nbs,n,i,j,k,*idx,*nidx;
93 
94   PetscFunctionBegin;
95   Nbs   = baij->Nbs;
96 
97   nidx  = (int *) PetscMalloc((Nbs*bs+1)*sizeof(int)); CHKPTRQ(nidx);
98 
99   for ( i=0; i<imax; i++ ) {
100     ierr = ISGetIndices(is_in[i],&idx);  CHKERRQ(ierr);
101     ierr = ISGetSize(is_in[i],&n);  CHKERRQ(ierr);
102     for (j=0; j<n ; ++j){
103       for (k=0; k<bs; k++)
104         nidx[j*bs+k] = idx[j]*bs+k;
105     }
106     ierr = ISRestoreIndices(is_in[i],&idx);  CHKERRQ(ierr);
107     ierr = ISCreateGeneral(PETSC_COMM_SELF, n*bs, nidx, (is_out+i)); CHKERRQ(ierr);
108   }
109   PetscFree(nidx);
110   PetscFunctionReturn(0);
111 }
112 
113 
114 #undef __FUNC__
115 #define __FUNC__ "MatIncreaseOverlap_MPIBAIJ"
116 int MatIncreaseOverlap_MPIBAIJ(Mat C, int imax, IS *is, int ov)
117 {
118   int i, ierr;
119   IS  *is_new;
120 
121   PetscFunctionBegin;
122   is_new = (IS *)PetscMalloc(imax*sizeof(IS)); CHKPTRQ(is_new);
123   /* Convert the indices into block format */
124   ierr = MatCompressIndicesGeneral_MPIBAIJ(C, imax, is,is_new); CHKERRQ(ierr);
125   if (ov < 0){ SETERRQ(PETSC_ERR_ARG_OUTOFRANGE,0,"Negative overlap specified\n");}
126   for (i=0; i<ov; ++i) {
127     ierr = MatIncreaseOverlap_MPIBAIJ_Once(C, imax, is_new); CHKERRQ(ierr);
128   }
129   for (i=0; i<imax; i++) ISDestroy(is[i]);
130   ierr = MatExpandIndices_MPIBAIJ(C, imax, is_new,is); CHKERRQ(ierr);
131   for (i=0; i<imax; i++) ISDestroy(is_new[i]);
132   PetscFree(is_new);
133   PetscFunctionReturn(0);
134 }
135 
136 /*
137   Sample message format:
138   If a processor A wants processor B to process some elements corresponding
139   to index sets 1s[1], is[5]
140   mesg [0] = 2   ( no of index sets in the mesg)
141   -----------
142   mesg [1] = 1 => is[1]
143   mesg [2] = sizeof(is[1]);
144   -----------
145   mesg [5] = 5  => is[5]
146   mesg [6] = sizeof(is[5]);
147   -----------
148   mesg [7]
149   mesg [n]  datas[1]
150   -----------
151   mesg[n+1]
152   mesg[m]  data(is[5])
153   -----------
154 
155   Notes:
156   nrqs - no of requests sent (or to be sent out)
157   nrqr - no of requests recieved (which have to be or which have been processed
158 */
159 #undef __FUNC__
160 #define __FUNC__ "MatIncreaseOverlap_MPIBAIJ_Once"
161 static int MatIncreaseOverlap_MPIBAIJ_Once(Mat C, int imax, IS *is)
162 {
163   Mat_MPIBAIJ  *c = (Mat_MPIBAIJ *) C->data;
164   int         **idx, *n, *w1, *w2, *w3, *w4, *rtable,**data,len,*idx_i;
165   int         size,rank,Mbs,i,j,k,ierr,**rbuf,row,proc,nrqs,msz,**outdat,**ptr;
166   int         *ctr,*pa,tag,*tmp,bsz,nrqr,*isz,*isz1,**xdata,bsz1,**rbuf2;
167   BT          *table;
168   MPI_Comm    comm;
169   MPI_Request *s_waits1,*r_waits1,*s_waits2,*r_waits2;
170   MPI_Status  *s_status,*recv_status;
171 
172   PetscFunctionBegin;
173   comm   = C->comm;
174   tag    = C->tag;
175   size   = c->size;
176   rank   = c->rank;
177   Mbs      = c->Mbs;
178 
179   len    = (imax+1)*sizeof(int *) + (imax + Mbs)*sizeof(int);
180   idx    = (int **) PetscMalloc(len); CHKPTRQ(idx);
181   n      = (int *) (idx + imax);
182   rtable = n + imax;
183 
184   for (i=0; i<imax; i++) {
185     ierr = ISGetIndices(is[i],&idx[i]);  CHKERRQ(ierr);
186     ierr = ISGetSize(is[i],&n[i]);  CHKERRQ(ierr);
187   }
188 
189   /* Create hash table for the mapping :row -> proc*/
190   for (i=0,j=0; i<size; i++) {
191     len = c->rowners[i+1];
192     for (; j<len; j++) {
193       rtable[j] = i;
194     }
195   }
196 
197   /* evaluate communication - mesg to who, length of mesg, and buffer space
198      required. Based on this, buffers are allocated, and data copied into them*/
199   w1   = (int *)PetscMalloc(size*4*sizeof(int));CHKPTRQ(w1);/*  mesg size */
200   w2   = w1 + size;       /* if w2[i] marked, then a message to proc i*/
201   w3   = w2 + size;       /* no of IS that needs to be sent to proc i */
202   w4   = w3 + size;       /* temp work space used in determining w1, w2, w3 */
203   PetscMemzero(w1,size*3*sizeof(int)); /* initialise work vector*/
204   for (i=0; i<imax; i++) {
205     PetscMemzero(w4,size*sizeof(int)); /* initialise work vector*/
206     idx_i = idx[i];
207     len   = n[i];
208     for (j=0; j<len; j++) {
209       row  = idx_i[j];
210       proc = rtable[row];
211       w4[proc]++;
212     }
213     for (j=0; j<size; j++){
214       if (w4[j]) { w1[j] += w4[j]; w3[j]++;}
215     }
216   }
217 
218   nrqs     = 0;              /* no of outgoing messages */
219   msz      = 0;              /* total mesg length (for all proc */
220   w1[rank] = 0;              /* no mesg sent to intself */
221   w3[rank] = 0;
222   for ( i=0; i<size; i++) {
223     if (w1[i])  {w2[i] = 1; nrqs++;} /* there exists a message to proc i */
224   }
225   /* pa - is list of processors to communicate with */
226   pa = (int *)PetscMalloc((nrqs+1)*sizeof(int));CHKPTRQ(pa);
227   for (i=0,j=0; i<size; i++) {
228     if (w1[i]) {pa[j] = i; j++;}
229   }
230 
231   /* Each message would have a header = 1 + 2*(no of IS) + data */
232   for (i=0; i<nrqs; i++) {
233     j      = pa[i];
234     w1[j] += w2[j] + 2*w3[j];
235     msz   += w1[j];
236   }
237 
238 
239   /* Do a global reduction to determine how many messages to expect*/
240   {
241     int *rw1, *rw2;
242     rw1   = (int *) PetscMalloc(2*size*sizeof(int)); CHKPTRQ(rw1);
243     rw2   = rw1+size;
244     MPI_Allreduce(w1, rw1, size, MPI_INT, MPI_MAX, comm);
245     bsz   = rw1[rank];
246     MPI_Allreduce(w2, rw2, size, MPI_INT, MPI_SUM, comm);
247     nrqr  = rw2[rank];
248     PetscFree(rw1);
249   }
250 
251   /* Allocate memory for recv buffers . Prob none if nrqr = 0 ???? */
252   len     = (nrqr+1)*sizeof(int*) + nrqr*bsz*sizeof(int);
253   rbuf    = (int**) PetscMalloc(len);  CHKPTRQ(rbuf);
254   rbuf[0] = (int *) (rbuf + nrqr);
255   for (i=1; i<nrqr; ++i) rbuf[i] = rbuf[i-1] + bsz;
256 
257   /* Post the receives */
258   r_waits1 = (MPI_Request *) PetscMalloc((nrqr+1)*sizeof(MPI_Request));CHKPTRQ(r_waits1);
259   for (i=0; i<nrqr; ++i) {
260     MPI_Irecv(rbuf[i],bsz,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits1+i);
261   }
262 
263   /* Allocate Memory for outgoing messages */
264   len    = 2*size*sizeof(int*) + (size+msz)*sizeof(int);
265   outdat = (int **)PetscMalloc(len); CHKPTRQ(outdat);
266   ptr    = outdat + size;     /* Pointers to the data in outgoing buffers */
267   PetscMemzero(outdat,2*size*sizeof(int*));
268   tmp    = (int *) (outdat + 2*size);
269   ctr    = tmp + msz;
270 
271   {
272     int *iptr = tmp,ict  = 0;
273     for (i=0; i<nrqs; i++) {
274       j         = pa[i];
275       iptr     +=  ict;
276       outdat[j] = iptr;
277       ict       = w1[j];
278     }
279   }
280 
281   /* Form the outgoing messages */
282   /*plug in the headers*/
283   for (i=0; i<nrqs; i++) {
284     j            = pa[i];
285     outdat[j][0] = 0;
286     PetscMemzero(outdat[j]+1,2*w3[j]*sizeof(int));
287     ptr[j]       = outdat[j] + 2*w3[j] + 1;
288   }
289 
290   /* Memory for doing local proc's work*/
291   {
292     int  *d_p;
293     char *t_p;
294 
295     len      = (imax)*(sizeof(BT) + sizeof(int *) + sizeof(int)) +
296                (Mbs)*imax*sizeof(int)  + (Mbs/BITSPERBYTE+1)*imax*sizeof(char) + 1;
297     table    = (BT *)PetscMalloc(len);  CHKPTRQ(table);
298     PetscMemzero(table,len);
299     data     = (int **)(table + imax);
300     isz      = (int  *)(data  + imax);
301     d_p      = (int  *)(isz   + imax);
302     t_p      = (char *)(d_p   + Mbs*imax);
303     for (i=0; i<imax; i++) {
304       table[i] = t_p + (Mbs/BITSPERBYTE+1)*i;
305       data[i]  = d_p + (Mbs)*i;
306     }
307   }
308 
309   /* Parse the IS and update local tables and the outgoing buf with the data*/
310   {
311     int  n_i,*data_i,isz_i,*outdat_j,ctr_j;
312     BT   table_i;
313 
314     for (i=0; i<imax; i++) {
315       PetscMemzero(ctr,size*sizeof(int));
316       n_i     = n[i];
317       table_i = table[i];
318       idx_i   = idx[i];
319       data_i  = data[i];
320       isz_i   = isz[i];
321       for (j=0;  j<n_i; j++) {  /* parse the indices of each IS */
322         row  = idx_i[j];
323         proc = rtable[row];
324         if (proc != rank) { /* copy to the outgoing buffer */
325           ctr[proc]++;
326           *ptr[proc] = row;
327           ptr[proc]++;
328         }
329         else { /* Update the local table */
330           if (!BTLookupSet(table_i,row)) { data_i[isz_i++] = row;}
331         }
332       }
333       /* Update the headers for the current IS */
334       for (j=0; j<size; j++) { /* Can Optimise this loop by using pa[] */
335         if ((ctr_j = ctr[j])) {
336           outdat_j        = outdat[j];
337           k               = ++outdat_j[0];
338           outdat_j[2*k]   = ctr_j;
339           outdat_j[2*k-1] = i;
340         }
341       }
342       isz[i] = isz_i;
343     }
344   }
345 
346 
347 
348   /*  Now  post the sends */
349   s_waits1 = (MPI_Request *) PetscMalloc((nrqs+1)*sizeof(MPI_Request));CHKPTRQ(s_waits1);
350   for (i=0; i<nrqs; ++i) {
351     j = pa[i];
352     MPI_Isend(outdat[j], w1[j], MPI_INT, j, tag, comm, s_waits1+i);
353   }
354 
355   /* No longer need the original indices*/
356   for (i=0; i<imax; ++i) {
357     ierr = ISRestoreIndices(is[i], idx+i); CHKERRQ(ierr);
358   }
359   PetscFree(idx);
360 
361   for (i=0; i<imax; ++i) {
362     ierr = ISDestroy(is[i]); CHKERRQ(ierr);
363   }
364 
365   /* Do Local work*/
366   ierr = MatIncreaseOverlap_MPIBAIJ_Local(C,imax,table,isz,data);CHKERRQ(ierr);
367 
368   /* Receive messages*/
369   {
370     int        index;
371 
372     recv_status = (MPI_Status *) PetscMalloc((nrqr+1)*sizeof(MPI_Status));CHKPTRQ(recv_status);
373     for (i=0; i<nrqr; ++i) {
374       MPI_Waitany(nrqr, r_waits1, &index, recv_status+i);
375     }
376 
377     s_status = (MPI_Status *) PetscMalloc((nrqs+1)*sizeof(MPI_Status));CHKPTRQ(s_status);
378     MPI_Waitall(nrqs,s_waits1,s_status);
379   }
380 
381   /* Phase 1 sends are complete - deallocate buffers */
382   PetscFree(outdat);
383   PetscFree(w1);
384 
385   xdata = (int **)PetscMalloc((nrqr+1)*sizeof(int *)); CHKPTRQ(xdata);
386   isz1  = (int *)PetscMalloc((nrqr+1)*sizeof(int)); CHKPTRQ(isz1);
387   ierr  = MatIncreaseOverlap_MPIBAIJ_Receive(C,nrqr,rbuf,xdata,isz1);CHKERRQ(ierr);
388   PetscFree(rbuf);
389 
390   /* Send the data back*/
391   /* Do a global reduction to know the buffer space req for incoming messages*/
392   {
393     int *rw1, *rw2;
394 
395     rw1 = (int *)PetscMalloc(2*size*sizeof(int)); CHKPTRQ(rw1);
396     PetscMemzero(rw1,2*size*sizeof(int));
397     rw2 = rw1+size;
398     for (i=0; i<nrqr; ++i) {
399       proc      = recv_status[i].MPI_SOURCE;
400       rw1[proc] = isz1[i];
401     }
402 
403     MPI_Allreduce(rw1, rw2, size, MPI_INT, MPI_MAX, comm);
404     bsz1   = rw2[rank];
405     PetscFree(rw1);
406   }
407 
408   /* Allocate buffers*/
409 
410   /* Allocate memory for recv buffers. Prob none if nrqr = 0 ???? */
411   len      = (nrqs+1)*sizeof(int*) + nrqs*bsz1*sizeof(int);
412   rbuf2    = (int**) PetscMalloc(len);  CHKPTRQ(rbuf2);
413   rbuf2[0] = (int *) (rbuf2 + nrqs);
414   for (i=1; i<nrqs; ++i) rbuf2[i] = rbuf2[i-1] + bsz1;
415 
416   /* Post the receives */
417   r_waits2 = (MPI_Request *)PetscMalloc((nrqs+1)*sizeof(MPI_Request));CHKPTRQ(r_waits2);
418   for (i=0; i<nrqs; ++i) {
419     MPI_Irecv(rbuf2[i], bsz1, MPI_INT, MPI_ANY_SOURCE, tag, comm, r_waits2+i);
420   }
421 
422   /*  Now  post the sends */
423   s_waits2 = (MPI_Request *) PetscMalloc((nrqr+1)*sizeof(MPI_Request));CHKPTRQ(s_waits2);
424   for (i=0; i<nrqr; ++i) {
425     j = recv_status[i].MPI_SOURCE;
426     MPI_Isend( xdata[i], isz1[i], MPI_INT, j, tag, comm, s_waits2+i);
427   }
428 
429   /* receive work done on other processors*/
430   {
431     int         index, is_no, ct1, max,*rbuf2_i,isz_i,*data_i,jmax;
432     BT          table_i;
433     MPI_Status  *status2;
434 
435     status2 = (MPI_Status *) PetscMalloc((nrqs+1)*sizeof(MPI_Status));CHKPTRQ(status2);
436 
437     for (i=0; i<nrqs; ++i) {
438       MPI_Waitany(nrqs, r_waits2, &index, status2+i);
439       /* Process the message*/
440       rbuf2_i = rbuf2[index];
441       ct1     = 2*rbuf2_i[0]+1;
442       jmax    = rbuf2[index][0];
443       for (j=1; j<=jmax; j++) {
444         max     = rbuf2_i[2*j];
445         is_no   = rbuf2_i[2*j-1];
446         isz_i   = isz[is_no];
447         data_i  = data[is_no];
448         table_i = table[is_no];
449         for (k=0; k<max; k++,ct1++) {
450           row = rbuf2_i[ct1];
451           if (!BTLookupSet(table_i,row)) { data_i[isz_i++] = row;}
452         }
453         isz[is_no] = isz_i;
454       }
455     }
456     MPI_Waitall(nrqr,s_waits2,status2);
457     PetscFree(status2);
458   }
459 
460   for (i=0; i<imax; ++i) {
461     ierr = ISCreateGeneral(PETSC_COMM_SELF, isz[i], data[i], is+i); CHKERRQ(ierr);
462   }
463 
464   PetscFree(pa);
465   PetscFree(rbuf2);
466   PetscFree(s_waits1);
467   PetscFree(r_waits1);
468   PetscFree(s_waits2);
469   PetscFree(r_waits2);
470   PetscFree(table);
471   PetscFree(s_status);
472   PetscFree(recv_status);
473   PetscFree(xdata[0]);
474   PetscFree(xdata);
475   PetscFree(isz1);
476   PetscFunctionReturn(0);
477 }
478 
479 #undef __FUNC__
480 #define __FUNC__ "MatIncreaseOverlap_MPIBAIJ_Local"
481 /*
482    MatIncreaseOverlap_MPIBAIJ_Local - Called by MatincreaseOverlap, to do
483        the work on the local processor.
484 
485      Inputs:
486       C      - MAT_MPIBAIJ;
487       imax - total no of index sets processed at a time;
488       table  - an array of char - size = Mbs bits.
489 
490      Output:
491       isz    - array containing the count of the solution elements correspondign
492                to each index set;
493       data   - pointer to the solutions
494 */
495 static int MatIncreaseOverlap_MPIBAIJ_Local(Mat C,int imax,BT *table,int *isz,
496                                            int **data)
497 {
498   Mat_MPIBAIJ *c = (Mat_MPIBAIJ *) C->data;
499   Mat        A = c->A, B = c->B;
500   Mat_SeqBAIJ *a = (Mat_SeqBAIJ*)A->data,*b = (Mat_SeqBAIJ*)B->data;
501   int        start, end, val, max, rstart,cstart,*ai, *aj;
502   int        *bi, *bj, *garray, i, j, k, row,*data_i,isz_i;
503   BT         table_i;
504 
505   PetscFunctionBegin;
506   rstart = c->rstart;
507   cstart = c->cstart;
508   ai     = a->i;
509   aj     = a->j;
510   bi     = b->i;
511   bj     = b->j;
512   garray = c->garray;
513 
514 
515   for (i=0; i<imax; i++) {
516     data_i  = data[i];
517     table_i = table[i];
518     isz_i   = isz[i];
519     for (j=0, max=isz[i]; j<max; j++) {
520       row   = data_i[j] - rstart;
521       start = ai[row];
522       end   = ai[row+1];
523       for (k=start; k<end; k++) { /* Amat */
524         val = aj[k] + cstart;
525         if (!BTLookupSet(table_i,val)) { data_i[isz_i++] = val;}
526       }
527       start = bi[row];
528       end   = bi[row+1];
529       for (k=start; k<end; k++) { /* Bmat */
530         val = garray[bj[k]];
531         if (!BTLookupSet(table_i,val)) { data_i[isz_i++] = val;}
532       }
533     }
534     isz[i] = isz_i;
535   }
536   PetscFunctionReturn(0);
537 }
538 #undef __FUNC__
539 #define __FUNC__ "MatIncreaseOverlap_MPIBAIJ_Receive"
540 /*
541       MatIncreaseOverlap_MPIBAIJ_Receive - Process the recieved messages,
542          and return the output
543 
544          Input:
545            C    - the matrix
546            nrqr - no of messages being processed.
547            rbuf - an array of pointers to the recieved requests
548 
549          Output:
550            xdata - array of messages to be sent back
551            isz1  - size of each message
552 
553   For better efficiency perhaps we should malloc seperately each xdata[i],
554 then if a remalloc is required we need only copy the data for that one row
555 rather then all previous rows as it is now where a single large chunck of
556 memory is used.
557 
558 */
559 static int MatIncreaseOverlap_MPIBAIJ_Receive(Mat C,int nrqr,int **rbuf,
560                                             int **xdata, int * isz1)
561 {
562   Mat_MPIBAIJ  *c = (Mat_MPIBAIJ *) C->data;
563   Mat         A = c->A, B = c->B;
564   Mat_SeqBAIJ  *a = (Mat_SeqBAIJ*)A->data,*b = (Mat_SeqBAIJ*)B->data;
565   int         rstart,cstart,*ai, *aj, *bi, *bj, *garray, i, j, k;
566   int         row,total_sz,ct, ct1, ct2, ct3,mem_estimate, oct2, l, start, end;
567   int         val, max1, max2, rank, Mbs, no_malloc =0, *tmp, new_estimate, ctr;
568   int         *rbuf_i,kmax,rbuf_0,ierr;
569   BT          xtable;
570 
571   PetscFunctionBegin;
572   rank   = c->rank;
573   Mbs     = c->Mbs;
574   rstart = c->rstart;
575   cstart = c->cstart;
576   ai     = a->i;
577   aj     = a->j;
578   bi     = b->i;
579   bj     = b->j;
580   garray = c->garray;
581 
582 
583   for (i=0,ct=0,total_sz=0; i<nrqr; ++i) {
584     rbuf_i =  rbuf[i];
585     rbuf_0 =  rbuf_i[0];
586     ct     += rbuf_0;
587     for (j=1; j<=rbuf_0; j++) { total_sz += rbuf_i[2*j]; }
588   }
589 
590   max1         = ct*(a->nz +b->nz)/c->Mbs;
591   mem_estimate =  3*((total_sz > max1 ? total_sz : max1)+1);
592   xdata[0]     = (int *)PetscMalloc(mem_estimate*sizeof(int)); CHKPTRQ(xdata[0]);
593   ++no_malloc;
594   ierr         = BTCreate(Mbs,xtable); CHKERRQ(ierr);
595   PetscMemzero(isz1,nrqr*sizeof(int));
596 
597   ct3 = 0;
598   for (i=0; i<nrqr; i++) { /* for easch mesg from proc i */
599     rbuf_i =  rbuf[i];
600     rbuf_0 =  rbuf_i[0];
601     ct1    =  2*rbuf_0+1;
602     ct2    =  ct1;
603     ct3    += ct1;
604     for (j=1; j<=rbuf_0; j++) { /* for each IS from proc i*/
605       BTMemzero(Mbs,xtable);
606       oct2 = ct2;
607       kmax = rbuf_i[2*j];
608       for (k=0; k<kmax; k++, ct1++) {
609         row = rbuf_i[ct1];
610         if (!BTLookupSet(xtable,row)) {
611           if (!(ct3 < mem_estimate)) {
612             new_estimate = (int)(1.5*mem_estimate)+1;
613             tmp          = (int*) PetscMalloc(new_estimate * sizeof(int));CHKPTRQ(tmp);
614             PetscMemcpy(tmp,xdata[0],mem_estimate*sizeof(int));
615             PetscFree(xdata[0]);
616             xdata[0]     = tmp;
617             mem_estimate = new_estimate; ++no_malloc;
618             for (ctr=1; ctr<=i; ctr++) { xdata[ctr] = xdata[ctr-1] + isz1[ctr-1];}
619           }
620           xdata[i][ct2++] = row;
621           ct3++;
622         }
623       }
624       for (k=oct2,max2=ct2; k<max2; k++)  {
625         row   = xdata[i][k] - rstart;
626         start = ai[row];
627         end   = ai[row+1];
628         for (l=start; l<end; l++) {
629           val = aj[l] + cstart;
630           if (!BTLookupSet(xtable,val)) {
631             if (!(ct3 < mem_estimate)) {
632               new_estimate = (int)(1.5*mem_estimate)+1;
633               tmp          = (int*) PetscMalloc(new_estimate * sizeof(int));CHKPTRQ(tmp);
634               PetscMemcpy(tmp,xdata[0],mem_estimate*sizeof(int));
635               PetscFree(xdata[0]);
636               xdata[0]     = tmp;
637               mem_estimate = new_estimate; ++no_malloc;
638               for (ctr=1; ctr<=i; ctr++) { xdata[ctr] = xdata[ctr-1] + isz1[ctr-1];}
639             }
640             xdata[i][ct2++] = val;
641             ct3++;
642           }
643         }
644         start = bi[row];
645         end   = bi[row+1];
646         for (l=start; l<end; l++) {
647           val = garray[bj[l]];
648           if (!BTLookupSet(xtable,val)) {
649             if (!(ct3 < mem_estimate)) {
650               new_estimate = (int)(1.5*mem_estimate)+1;
651               tmp          = (int*) PetscMalloc(new_estimate * sizeof(int));CHKPTRQ(tmp);
652               PetscMemcpy(tmp,xdata[0],mem_estimate*sizeof(int));
653               PetscFree(xdata[0]);
654               xdata[0]     = tmp;
655               mem_estimate = new_estimate; ++no_malloc;
656               for (ctr =1; ctr <=i; ctr++) { xdata[ctr] = xdata[ctr-1] + isz1[ctr-1];}
657             }
658             xdata[i][ct2++] = val;
659             ct3++;
660           }
661         }
662       }
663       /* Update the header*/
664       xdata[i][2*j]   = ct2 - oct2; /* Undo the vector isz1 and use only a var*/
665       xdata[i][2*j-1] = rbuf_i[2*j-1];
666     }
667     xdata[i][0] = rbuf_0;
668     xdata[i+1]  = xdata[i] + ct2;
669     isz1[i]     = ct2; /* size of each message */
670   }
671   BTDestroy(xtable);
672   PLogInfo(0,"MatIncreaseOverlap_MPIBAIJ:[%d] Allocated %d bytes, required %d bytes, no of mallocs = %d\n",rank,mem_estimate, ct3,no_malloc);
673   PetscFunctionReturn(0);
674 }
675 
676 static int MatGetSubMatrices_MPIBAIJ_local(Mat,int,IS *,IS *,MatGetSubMatrixCall,Mat *);
677 
678 #undef __FUNC__
679 #define __FUNC__ "MatGetSubMatrices_MPIBAIJ"
680 int MatGetSubMatrices_MPIBAIJ(Mat C,int ismax,IS *isrow,IS *iscol,
681                              MatGetSubMatrixCall scall,Mat **submat)
682 {
683   IS          *isrow_new,*iscol_new;
684   Mat_MPIBAIJ *c = (Mat_MPIBAIJ *) C->data;
685   int         nmax,nstages_local,nstages,i,pos,max_no,ierr;
686 
687   PetscFunctionBegin;
688   /* The compression and expansion should be avoided. Does'nt point
689      out errors might change the indices hence buggey */
690 
691   isrow_new = (IS *)PetscMalloc(2*ismax*sizeof(IS)); CHKPTRQ(isrow_new);
692   iscol_new = isrow_new + ismax;
693   ierr = MatCompressIndicesSorted_MPIBAIJ(C, ismax, isrow,isrow_new); CHKERRQ(ierr);
694   ierr = MatCompressIndicesSorted_MPIBAIJ(C, ismax, iscol,iscol_new); CHKERRQ(ierr);
695 
696   /* Allocate memory to hold all the submatrices */
697   if (scall != MAT_REUSE_MATRIX) {
698     *submat = (Mat *)PetscMalloc((ismax+1)*sizeof(Mat));CHKPTRQ(*submat);
699   }
700   /* Determine the number of stages through which submatrices are done */
701   nmax          = 20*1000000 / (c->Nbs * sizeof(int));
702   if (nmax == 0) nmax = 1;
703   nstages_local = ismax/nmax + ((ismax % nmax)?1:0);
704 
705   /* Make sure every porcessor loops through the nstages */
706   MPI_Allreduce(&nstages_local,&nstages,1,MPI_INT,MPI_MAX,C->comm);
707 
708 
709   for ( i=0,pos=0; i<nstages; i++ ) {
710     if (pos+nmax <= ismax) max_no = nmax;
711     else if (pos == ismax) max_no = 0;
712     else                   max_no = ismax-pos;
713     ierr = MatGetSubMatrices_MPIBAIJ_local(C,max_no,isrow_new+pos,iscol_new+pos,scall,*submat+pos); CHKERRQ(ierr);
714     pos += max_no;
715   }
716 
717   for (i=0; i<ismax; i++) {
718     ISDestroy(isrow_new[i]);
719     ISDestroy(iscol_new[i]);
720   }
721   PetscFree(isrow_new);
722   PetscFunctionReturn(0);
723 }
724 
725 /* -------------------------------------------------------------------------*/
726 #undef __FUNC__
727 #define __FUNC__ "MatGetSubMatrices_MPIBAIJ_local"
728 static int MatGetSubMatrices_MPIBAIJ_local(Mat C,int ismax,IS *isrow,IS *iscol,
729                              MatGetSubMatrixCall scall,Mat *submats)
730 {
731   Mat_MPIBAIJ  *c = (Mat_MPIBAIJ *) C->data;
732   Mat         A = c->A;
733   Mat_SeqBAIJ  *a = (Mat_SeqBAIJ*)A->data, *b = (Mat_SeqBAIJ*)c->B->data, *mat;
734   int         **irow,**icol,*nrow,*ncol,*w1,*w2,*w3,*w4,*rtable,start,end,size;
735   int         **sbuf1,**sbuf2, rank, Mbs,i,j,k,l,ct1,ct2,ierr, **rbuf1,row,proc;
736   int         nrqs, msz, **ptr,index,*req_size,*ctr,*pa,*tmp,tcol,bsz,nrqr;
737   int         **rbuf3,*req_source,**sbuf_aj, **rbuf2, max1,max2,**rmap;
738   int         **cmap,**lens,is_no,ncols,*cols,mat_i,*mat_j,tmp2,jmax,*irow_i;
739   int         len,ctr_j,*sbuf1_j,*sbuf_aj_i,*rbuf1_i,kmax,*cmap_i,*lens_i;
740   int         *rmap_i,bs=c->bs,bs2=c->bs2,*a_j=a->j,*b_j=b->j,*cworkA, *cworkB;
741   int         cstart = c->cstart,nzA,nzB,*a_i=a->i,*b_i=b->i,imark;
742   int         *bmap = c->garray,ctmp,rstart=c->rstart,tag0,tag1,tag2,tag3;
743   MPI_Request *s_waits1,*r_waits1,*s_waits2,*r_waits2,*r_waits3;
744   MPI_Request *r_waits4,*s_waits3,*s_waits4;
745   MPI_Status  *r_status1,*r_status2,*s_status1,*s_status3,*s_status2;
746   MPI_Status  *r_status3,*r_status4,*s_status4;
747   MPI_Comm    comm;
748   Scalar      **rbuf4,**sbuf_aa,*vals,*mat_a,*sbuf_aa_i,*vworkA,*vworkB;
749   Scalar      *a_a=a->a,*b_a=b->a;
750 
751   PetscFunctionBegin;
752   comm   = C->comm;
753   tag0    = C->tag;
754   size   = c->size;
755   rank   = c->rank;
756   Mbs      = c->Mbs;
757 
758   /* Get some new tags to keep the communication clean */
759   ierr = PetscObjectGetNewTag((PetscObject)C,&tag1); CHKERRQ(ierr);
760   ierr = PetscObjectGetNewTag((PetscObject)C,&tag2); CHKERRQ(ierr);
761   ierr = PetscObjectGetNewTag((PetscObject)C,&tag3); CHKERRQ(ierr);
762 
763   /* Check if the col indices are sorted */
764   for (i=0; i<ismax; i++) {
765     ierr = ISSorted(iscol[i],(PetscTruth*)&j);
766     if (!j) SETERRQ(1,0,"IS is not sorted");
767   }
768 
769   len    = (2*ismax+1)*(sizeof(int *) + sizeof(int)) + (Mbs+1)*sizeof(int);
770   irow   = (int **)PetscMalloc(len); CHKPTRQ(irow);
771   icol   = irow + ismax;
772   nrow   = (int *) (icol + ismax);
773   ncol   = nrow + ismax;
774   rtable = ncol + ismax;
775 
776   for (i=0; i<ismax; i++) {
777     ierr = ISGetIndices(isrow[i],&irow[i]);  CHKERRQ(ierr);
778     ierr = ISGetIndices(iscol[i],&icol[i]);  CHKERRQ(ierr);
779     ierr = ISGetSize(isrow[i],&nrow[i]);  CHKERRQ(ierr);
780     ierr = ISGetSize(iscol[i],&ncol[i]);  CHKERRQ(ierr);
781   }
782 
783   /* Create hash table for the mapping :row -> proc*/
784   for (i=0,j=0; i<size; i++) {
785     jmax = c->rowners[i+1];
786     for (; j<jmax; j++) {
787       rtable[j] = i;
788     }
789   }
790 
791   /* evaluate communication - mesg to who, length of mesg, and buffer space
792      required. Based on this, buffers are allocated, and data copied into them*/
793   w1     = (int *)PetscMalloc(size*4*sizeof(int));CHKPTRQ(w1); /* mesg size */
794   w2     = w1 + size;      /* if w2[i] marked, then a message to proc i*/
795   w3     = w2 + size;      /* no of IS that needs to be sent to proc i */
796   w4     = w3 + size;      /* temp work space used in determining w1, w2, w3 */
797   PetscMemzero(w1,size*3*sizeof(int)); /* initialise work vector*/
798   for (i=0; i<ismax; i++) {
799     PetscMemzero(w4,size*sizeof(int)); /* initialise work vector*/
800     jmax   = nrow[i];
801     irow_i = irow[i];
802     for (j=0; j<jmax; j++) {
803       row  = irow_i[j];
804       proc = rtable[row];
805       w4[proc]++;
806     }
807     for (j=0; j<size; j++) {
808       if (w4[j]) { w1[j] += w4[j];  w3[j]++;}
809     }
810   }
811 
812   nrqs     = 0;              /* no of outgoing messages */
813   msz      = 0;              /* total mesg length for all proc */
814   w1[rank] = 0;              /* no mesg sent to intself */
815   w3[rank] = 0;
816   for (i=0; i<size; i++) {
817     if (w1[i])  { w2[i] = 1; nrqs++;} /* there exists a message to proc i */
818   }
819   pa = (int *)PetscMalloc((nrqs+1)*sizeof(int));CHKPTRQ(pa); /*(proc -array)*/
820   for (i=0, j=0; i<size; i++) {
821     if (w1[i]) { pa[j] = i; j++; }
822   }
823 
824   /* Each message would have a header = 1 + 2*(no of IS) + data */
825   for (i=0; i<nrqs; i++) {
826     j     = pa[i];
827     w1[j] += w2[j] + 2* w3[j];
828     msz   += w1[j];
829   }
830   /* Do a global reduction to determine how many messages to expect*/
831   {
832     int *rw1, *rw2;
833     rw1 = (int *)PetscMalloc(2*size*sizeof(int)); CHKPTRQ(rw1);
834     rw2 = rw1+size;
835     MPI_Allreduce(w1, rw1, size, MPI_INT, MPI_MAX, comm);
836     bsz   = rw1[rank];
837     MPI_Allreduce(w2, rw2, size, MPI_INT, MPI_SUM, comm);
838     nrqr  = rw2[rank];
839     PetscFree(rw1);
840   }
841 
842   /* Allocate memory for recv buffers . Prob none if nrqr = 0 ???? */
843   len      = (nrqr+1)*sizeof(int*) + nrqr*bsz*sizeof(int);
844   rbuf1    = (int**) PetscMalloc(len);  CHKPTRQ(rbuf1);
845   rbuf1[0] = (int *) (rbuf1 + nrqr);
846   for (i=1; i<nrqr; ++i) rbuf1[i] = rbuf1[i-1] + bsz;
847 
848   /* Post the receives */
849   r_waits1 = (MPI_Request *) PetscMalloc((nrqr+1)*sizeof(MPI_Request));CHKPTRQ(r_waits1);
850   for (i=0; i<nrqr; ++i) {
851     MPI_Irecv(rbuf1[i],bsz,MPI_INT,MPI_ANY_SOURCE,tag0,comm,r_waits1+i);
852   }
853 
854   /* Allocate Memory for outgoing messages */
855   len      = 2*size*sizeof(int*) + 2*msz*sizeof(int) + size*sizeof(int);
856   sbuf1    = (int **)PetscMalloc(len); CHKPTRQ(sbuf1);
857   ptr      = sbuf1 + size;   /* Pointers to the data in outgoing buffers */
858   PetscMemzero(sbuf1,2*size*sizeof(int*));
859   /* allocate memory for outgoing data + buf to receive the first reply */
860   tmp      = (int *) (ptr + size);
861   ctr      = tmp + 2*msz;
862 
863   {
864 
865     int *iptr = tmp,ict = 0;
866     for (i=0; i<nrqs; i++) {
867       j         = pa[i];
868       iptr     += ict;
869       sbuf1[j]  = iptr;
870       ict       = w1[j];
871     }
872   }
873 
874   /* Form the outgoing messages */
875   /* Initialise the header space */
876   for (i=0; i<nrqs; i++) {
877     j           = pa[i];
878     sbuf1[j][0] = 0;
879     PetscMemzero(sbuf1[j]+1, 2*w3[j]*sizeof(int));
880     ptr[j]      = sbuf1[j] + 2*w3[j] + 1;
881   }
882 
883   /* Parse the isrow and copy data into outbuf */
884   for (i=0; i<ismax; i++) {
885     PetscMemzero(ctr,size*sizeof(int));
886     irow_i = irow[i];
887     jmax   = nrow[i];
888     for (j=0; j<jmax; j++) {  /* parse the indices of each IS */
889       row  = irow_i[j];
890       proc = rtable[row];
891       if (proc != rank) { /* copy to the outgoing buf*/
892         ctr[proc]++;
893         *ptr[proc] = row;
894         ptr[proc]++;
895       }
896     }
897     /* Update the headers for the current IS */
898     for (j=0; j<size; j++) { /* Can Optimise this loop too */
899       if ((ctr_j = ctr[j])) {
900         sbuf1_j        = sbuf1[j];
901         k              = ++sbuf1_j[0];
902         sbuf1_j[2*k]   = ctr_j;
903         sbuf1_j[2*k-1] = i;
904       }
905     }
906   }
907 
908   /*  Now  post the sends */
909   s_waits1 = (MPI_Request *) PetscMalloc((nrqs+1)*sizeof(MPI_Request));CHKPTRQ(s_waits1);
910   for (i=0; i<nrqs; ++i) {
911     j = pa[i];
912     /* printf("[%d] Send Req to %d: size %d \n", rank,j, w1[j]); */
913     MPI_Isend( sbuf1[j], w1[j], MPI_INT, j, tag0, comm, s_waits1+i);
914   }
915 
916   /* Post Recieves to capture the buffer size */
917   r_waits2 = (MPI_Request *) PetscMalloc((nrqs+1)*sizeof(MPI_Request));CHKPTRQ(r_waits2);
918   rbuf2    = (int**)PetscMalloc((nrqs+1)*sizeof(int *));CHKPTRQ(rbuf2);
919   rbuf2[0] = tmp + msz;
920   for (i=1; i<nrqs; ++i) {
921     j        = pa[i];
922     rbuf2[i] = rbuf2[i-1]+w1[pa[i-1]];
923   }
924   for (i=0; i<nrqs; ++i) {
925     j = pa[i];
926     MPI_Irecv( rbuf2[i], w1[j], MPI_INT, j, tag1, comm, r_waits2+i);
927   }
928 
929   /* Send to other procs the buf size they should allocate */
930 
931 
932   /* Receive messages*/
933   s_waits2  = (MPI_Request *) PetscMalloc((nrqr+1)*sizeof(MPI_Request));CHKPTRQ(s_waits2);
934   r_status1 = (MPI_Status *) PetscMalloc((nrqr+1)*sizeof(MPI_Status));CHKPTRQ(r_status1);
935   len         = 2*nrqr*sizeof(int) + (nrqr+1)*sizeof(int*);
936   sbuf2       = (int**) PetscMalloc(len);CHKPTRQ(sbuf2);
937   req_size    = (int *) (sbuf2 + nrqr);
938   req_source  = req_size + nrqr;
939 
940   {
941     Mat_SeqBAIJ *sA = (Mat_SeqBAIJ*) c->A->data, *sB = (Mat_SeqBAIJ*) c->B->data;
942     int        *sAi = sA->i, *sBi = sB->i, id;
943     int        *sbuf2_i;
944 
945     for (i=0; i<nrqr; ++i) {
946       MPI_Waitany(nrqr, r_waits1, &index, r_status1+i);
947       req_size[index] = 0;
948       rbuf1_i         = rbuf1[index];
949       start           = 2*rbuf1_i[0] + 1;
950       MPI_Get_count(r_status1+i,MPI_INT, &end);
951       sbuf2[index] = (int *)PetscMalloc(end*sizeof(int));CHKPTRQ(sbuf2[index]);
952       sbuf2_i      = sbuf2[index];
953       for (j=start; j<end; j++) {
954         id               = rbuf1_i[j] - rstart;
955         ncols            = sAi[id+1] - sAi[id] + sBi[id+1] - sBi[id];
956         sbuf2_i[j]       = ncols;
957         req_size[index] += ncols;
958       }
959       req_source[index] = r_status1[i].MPI_SOURCE;
960       /* form the header */
961       sbuf2_i[0]   = req_size[index];
962       for (j=1; j<start; j++) { sbuf2_i[j] = rbuf1_i[j]; }
963       MPI_Isend(sbuf2_i,end,MPI_INT,req_source[index],tag1,comm,s_waits2+i);
964     }
965   }
966   PetscFree(r_status1); PetscFree(r_waits1);
967 
968   /*  recv buffer sizes */
969   /* Receive messages*/
970 
971   rbuf3     = (int**)PetscMalloc((nrqs+1)*sizeof(int*)); CHKPTRQ(rbuf3);
972   rbuf4     = (Scalar**)PetscMalloc((nrqs+1)*sizeof(Scalar*));CHKPTRQ(rbuf4);
973   r_waits3  = (MPI_Request *) PetscMalloc((nrqs+1)*sizeof(MPI_Request));CHKPTRQ(r_waits3);
974   r_waits4  = (MPI_Request *) PetscMalloc((nrqs+1)*sizeof(MPI_Request));CHKPTRQ(r_waits4);
975   r_status2 = (MPI_Status *) PetscMalloc((nrqs+1)*sizeof(MPI_Status));CHKPTRQ(r_status2);
976 
977   for (i=0; i<nrqs; ++i) {
978     MPI_Waitany(nrqs, r_waits2, &index, r_status2+i);
979     rbuf3[index] = (int *)PetscMalloc(rbuf2[index][0]*sizeof(int));CHKPTRQ(rbuf3[index]);
980     rbuf4[index] = (Scalar *)PetscMalloc(rbuf2[index][0]*bs2*sizeof(Scalar));CHKPTRQ(rbuf4[index]);
981     MPI_Irecv(rbuf3[index],rbuf2[index][0], MPI_INT,
982               r_status2[i].MPI_SOURCE, tag2, comm, r_waits3+index);
983     MPI_Irecv(rbuf4[index],rbuf2[index][0]*bs2, MPIU_SCALAR,
984               r_status2[i].MPI_SOURCE, tag3, comm, r_waits4+index);
985   }
986   PetscFree(r_status2); PetscFree(r_waits2);
987 
988   /* Wait on sends1 and sends2 */
989   s_status1 = (MPI_Status *) PetscMalloc((nrqs+1)*sizeof(MPI_Status));CHKPTRQ(s_status1);
990   s_status2 = (MPI_Status *) PetscMalloc((nrqr+1)*sizeof(MPI_Status));CHKPTRQ(s_status2);
991 
992   MPI_Waitall(nrqs,s_waits1,s_status1);
993   MPI_Waitall(nrqr,s_waits2,s_status2);
994   PetscFree(s_status1); PetscFree(s_status2);
995   PetscFree(s_waits1); PetscFree(s_waits2);
996 
997   /* Now allocate buffers for a->j, and send them off */
998   sbuf_aj = (int **)PetscMalloc((nrqr+1)*sizeof(int *));CHKPTRQ(sbuf_aj);
999   for (i=0,j=0; i<nrqr; i++) j += req_size[i];
1000   sbuf_aj[0] = (int*) PetscMalloc((j+1)*sizeof(int)); CHKPTRQ(sbuf_aj[0]);
1001   for (i=1; i<nrqr; i++)  sbuf_aj[i] = sbuf_aj[i-1] + req_size[i-1];
1002 
1003   s_waits3 = (MPI_Request *) PetscMalloc((nrqr+1)*sizeof(MPI_Request));CHKPTRQ(s_waits3);
1004   {
1005      for (i=0; i<nrqr; i++) {
1006       rbuf1_i   = rbuf1[i];
1007       sbuf_aj_i = sbuf_aj[i];
1008       ct1       = 2*rbuf1_i[0] + 1;
1009       ct2       = 0;
1010       for (j=1,max1=rbuf1_i[0]; j<=max1; j++) {
1011         kmax = rbuf1[i][2*j];
1012         for (k=0; k<kmax; k++,ct1++) {
1013           row    = rbuf1_i[ct1] - rstart;
1014           nzA    = a_i[row+1] - a_i[row];     nzB = b_i[row+1] - b_i[row];
1015           ncols  = nzA + nzB;
1016           cworkA = a_j + a_i[row]; cworkB = b_j + b_i[row];
1017 
1018           /* load the column indices for this row into cols*/
1019           cols  = sbuf_aj_i + ct2;
1020           for (l=0; l<nzB; l++) {
1021             if ((ctmp = bmap[cworkB[l]]) < cstart)  cols[l] = ctmp;
1022             else break;
1023           }
1024           imark = l;
1025           for (l=0; l<nzA; l++)   cols[imark+l] = cstart + cworkA[l];
1026           for (l=imark; l<nzB; l++) cols[nzA+l] = bmap[cworkB[l]];
1027           ct2 += ncols;
1028         }
1029       }
1030       MPI_Isend(sbuf_aj_i,req_size[i],MPI_INT,req_source[i],tag2,comm,s_waits3+i);
1031     }
1032   }
1033   r_status3 = (MPI_Status *) PetscMalloc((nrqs+1)*sizeof(MPI_Status));CHKPTRQ(r_status3);
1034   s_status3 = (MPI_Status *) PetscMalloc((nrqr+1)*sizeof(MPI_Status));CHKPTRQ(s_status3);
1035 
1036   /* Allocate buffers for a->a, and send them off */
1037   sbuf_aa = (Scalar **)PetscMalloc((nrqr+1)*sizeof(Scalar *));CHKPTRQ(sbuf_aa);
1038   for (i=0,j=0; i<nrqr; i++) j += req_size[i];
1039   sbuf_aa[0] = (Scalar*) PetscMalloc((j+1)*bs2*sizeof(Scalar));CHKPTRQ(sbuf_aa[0]);
1040   for (i=1; i<nrqr; i++)  sbuf_aa[i] = sbuf_aa[i-1] + req_size[i-1]*bs2;
1041 
1042   s_waits4 = (MPI_Request *) PetscMalloc((nrqr+1)*sizeof(MPI_Request));CHKPTRQ(s_waits4);
1043   {
1044     for (i=0; i<nrqr; i++) {
1045       rbuf1_i   = rbuf1[i];
1046       sbuf_aa_i = sbuf_aa[i];
1047       ct1       = 2*rbuf1_i[0]+1;
1048       ct2       = 0;
1049       for (j=1,max1=rbuf1_i[0]; j<=max1; j++) {
1050         kmax = rbuf1_i[2*j];
1051         for (k=0; k<kmax; k++,ct1++) {
1052           row    = rbuf1_i[ct1] - rstart;
1053           nzA    = a_i[row+1] - a_i[row];     nzB = b_i[row+1] - b_i[row];
1054           ncols  = nzA + nzB;
1055           cworkA = a_j + a_i[row];     cworkB = b_j + b_i[row];
1056           vworkA = a_a + a_i[row]*bs2; vworkB = b_a + b_i[row]*bs2;
1057 
1058           /* load the column values for this row into vals*/
1059           vals  = sbuf_aa_i+ct2*bs2;
1060           for (l=0; l<nzB; l++) {
1061             if ((bmap[cworkB[l]]) < cstart) {
1062               PetscMemcpy(vals+l*bs2,vworkB+l*bs2,bs2*sizeof(Scalar));
1063             }
1064             else break;
1065           }
1066           imark = l;
1067           for (l=0; l<nzA; l++) {
1068             PetscMemcpy(vals+(imark+l)*bs2,vworkA+l*bs2,bs2*sizeof(Scalar));
1069           }
1070           for (l=imark; l<nzB; l++) {
1071             PetscMemcpy(vals+(nzA+l)*bs2,vworkB+l*bs2,bs2*sizeof(Scalar));
1072           }
1073           ct2 += ncols;
1074         }
1075       }
1076       MPI_Isend(sbuf_aa_i,req_size[i]*bs2,MPIU_SCALAR,req_source[i],tag3,comm,s_waits4+i);
1077     }
1078   }
1079   r_status4 = (MPI_Status *) PetscMalloc((nrqs+1)*sizeof(MPI_Status));CHKPTRQ(r_status4);
1080   s_status4 = (MPI_Status *) PetscMalloc((nrqr+1)*sizeof(MPI_Status));CHKPTRQ(s_status4);
1081   PetscFree(rbuf1);
1082 
1083   /* Form the matrix */
1084   /* create col map */
1085   {
1086     int *icol_i;
1087 
1088     len     = (1+ismax)*sizeof(int *) + ismax*c->Nbs*sizeof(int);
1089     cmap    = (int **)PetscMalloc(len); CHKPTRQ(cmap);
1090     cmap[0] = (int *)(cmap + ismax);
1091     PetscMemzero(cmap[0],(1+ismax*c->Nbs)*sizeof(int));
1092     for (i=1; i<ismax; i++) { cmap[i] = cmap[i-1] + c->Nbs; }
1093     for (i=0; i<ismax; i++) {
1094       jmax   = ncol[i];
1095       icol_i = icol[i];
1096       cmap_i = cmap[i];
1097       for (j=0; j<jmax; j++) {
1098         cmap_i[icol_i[j]] = j+1;
1099       }
1100     }
1101   }
1102 
1103 
1104   /* Create lens which is required for MatCreate... */
1105   for (i=0,j=0; i<ismax; i++) { j += nrow[i]; }
1106   len     = (1+ismax)*sizeof(int *) + j*sizeof(int);
1107   lens    = (int **)PetscMalloc(len); CHKPTRQ(lens);
1108   lens[0] = (int *)(lens + ismax);
1109   PetscMemzero(lens[0], j*sizeof(int));
1110   for (i=1; i<ismax; i++) { lens[i] = lens[i-1] + nrow[i-1]; }
1111 
1112   /* Update lens from local data */
1113   for (i=0; i<ismax; i++) {
1114     jmax   = nrow[i];
1115     cmap_i = cmap[i];
1116     irow_i = irow[i];
1117     lens_i = lens[i];
1118     for (j=0; j<jmax; j++) {
1119       row  = irow_i[j];
1120       proc = rtable[row];
1121       if (proc == rank) {
1122         /* Get indices from matA and then from matB */
1123         row    = row - rstart;
1124         nzA    = a_i[row+1] - a_i[row];     nzB = b_i[row+1] - b_i[row];
1125         cworkA =  a_j + a_i[row]; cworkB = b_j + b_i[row];
1126         for (k=0; k<nzA; k++)
1127           if (cmap_i[cstart + cworkA[k]]) { lens_i[j]++;}
1128         for (k=0; k<nzB; k++)
1129           if (cmap_i[bmap[cworkB[k]]]) { lens_i[j]++;}
1130       }
1131     }
1132   }
1133 
1134   /* Create row map*/
1135   len     = (1+ismax)*sizeof(int *) + ismax*c->Mbs*sizeof(int);
1136   rmap    = (int **)PetscMalloc(len); CHKPTRQ(rmap);
1137   rmap[0] = (int *)(rmap + ismax);
1138   PetscMemzero(rmap[0],ismax*c->Mbs*sizeof(int));
1139   for (i=1; i<ismax; i++) { rmap[i] = rmap[i-1] + c->Mbs;}
1140   for (i=0; i<ismax; i++) {
1141     rmap_i = rmap[i];
1142     irow_i = irow[i];
1143     jmax   = nrow[i];
1144     for (j=0; j<jmax; j++) {
1145       rmap_i[irow_i[j]] = j;
1146     }
1147   }
1148 
1149   /* Update lens from offproc data */
1150   {
1151     int *rbuf2_i, *rbuf3_i, *sbuf1_i;
1152 
1153     for (tmp2=0; tmp2<nrqs; tmp2++) {
1154       MPI_Waitany(nrqs, r_waits3, &i, r_status3+tmp2);
1155       index   = pa[i];
1156       sbuf1_i = sbuf1[index];
1157       jmax    = sbuf1_i[0];
1158       ct1     = 2*jmax+1;
1159       ct2     = 0;
1160       rbuf2_i = rbuf2[i];
1161       rbuf3_i = rbuf3[i];
1162       for (j=1; j<=jmax; j++) {
1163         is_no   = sbuf1_i[2*j-1];
1164         max1    = sbuf1_i[2*j];
1165         lens_i  = lens[is_no];
1166         cmap_i  = cmap[is_no];
1167         rmap_i  = rmap[is_no];
1168         for (k=0; k<max1; k++,ct1++) {
1169           row  = rmap_i[sbuf1_i[ct1]]; /* the val in the new matrix to be */
1170           max2 = rbuf2_i[ct1];
1171           for (l=0; l<max2; l++,ct2++) {
1172             if (cmap_i[rbuf3_i[ct2]]) {
1173               lens_i[row]++;
1174             }
1175           }
1176         }
1177       }
1178     }
1179   }
1180   PetscFree(r_status3); PetscFree(r_waits3);
1181   MPI_Waitall(nrqr,s_waits3,s_status3);
1182   PetscFree(s_status3); PetscFree(s_waits3);
1183 
1184   /* Create the submatrices */
1185   if (scall == MAT_REUSE_MATRIX) {
1186     /*
1187         Assumes new rows are same length as the old rows, hence bug!
1188     */
1189     for (i=0; i<ismax; i++) {
1190       mat = (Mat_SeqBAIJ *)(submats[i]->data);
1191       if ((mat->mbs != nrow[i]) || (mat->nbs != ncol[i] || mat->bs != bs)) {
1192         SETERRQ(1,0,"Cannot reuse matrix. wrong size");
1193       }
1194       if (PetscMemcmp(mat->ilen,lens[i], mat->mbs *sizeof(int))) {
1195         SETERRQ(1,0,"Cannot reuse matrix. wrong no of nonzeros");
1196       }
1197       /* Initial matrix as if empty */
1198       PetscMemzero(mat->ilen,mat->mbs*sizeof(int));
1199       submats[i]->factor = C->factor;
1200     }
1201   }
1202   else {
1203     /* *submat = submats = (Mat *)PetscMalloc(ismax*sizeof(Mat)); CHKPTRQ(submats); */
1204     for (i=0; i<ismax; i++) {
1205       ierr = MatCreateSeqBAIJ(PETSC_COMM_SELF,a->bs,nrow[i]*bs,ncol[i]*bs,0,lens[i],submats+i);
1206              CHKERRQ(ierr);
1207     }
1208   }
1209 
1210   /* Assemble the matrices */
1211   /* First assemble the local rows */
1212   {
1213     int    ilen_row,*imat_ilen, *imat_j, *imat_i;
1214     Scalar *imat_a;
1215 
1216     for (i=0; i<ismax; i++) {
1217       mat       = (Mat_SeqBAIJ *) submats[i]->data;
1218       imat_ilen = mat->ilen;
1219       imat_j    = mat->j;
1220       imat_i    = mat->i;
1221       imat_a    = mat->a;
1222       cmap_i    = cmap[i];
1223       rmap_i    = rmap[i];
1224       irow_i    = irow[i];
1225       jmax      = nrow[i];
1226       for (j=0; j<jmax; j++) {
1227         row      = irow_i[j];
1228         proc     = rtable[row];
1229         if (proc == rank) {
1230           row      = row - rstart;
1231           nzA      = a_i[row+1] - a_i[row];
1232           nzB      = b_i[row+1] - b_i[row];
1233           cworkA   = a_j + a_i[row];
1234           cworkB   = b_j + b_i[row];
1235           vworkA   = a_a + a_i[row]*bs2;
1236           vworkB   = b_a + b_i[row]*bs2;
1237 
1238           row      = rmap_i[row + rstart];
1239           mat_i    = imat_i[row];
1240           mat_a    = imat_a + mat_i*bs2;
1241           mat_j    = imat_j + mat_i;
1242           ilen_row = imat_ilen[row];
1243 
1244           /* load the column indices for this row into cols*/
1245           for (l=0; l<nzB; l++) {
1246             if ((ctmp = bmap[cworkB[l]]) < cstart) {
1247               if ((tcol = cmap_i[ctmp])) {
1248                 *mat_j++ = tcol - 1;
1249                 PetscMemcpy(mat_a,vworkB+l*bs2,bs2*sizeof(Scalar)); mat_a += bs2;
1250                 ilen_row++;
1251               }
1252             }
1253             else break;
1254           }
1255           imark = l;
1256           for (l=0; l<nzA; l++) {
1257             if ((tcol = cmap_i[cstart + cworkA[l]])) {
1258               *mat_j++ = tcol - 1;
1259               PetscMemcpy(mat_a,vworkA+l*bs2,bs2*sizeof(Scalar)); mat_a += bs2;
1260               ilen_row++;
1261             }
1262           }
1263           for (l=imark; l<nzB; l++) {
1264             if ((tcol = cmap_i[bmap[cworkB[l]]])) {
1265               *mat_j++ = tcol - 1;
1266               PetscMemcpy(mat_a,vworkB+l*bs2,bs2*sizeof(Scalar)); mat_a += bs2;
1267               ilen_row++;
1268             }
1269           }
1270           imat_ilen[row] = ilen_row;
1271         }
1272       }
1273 
1274     }
1275   }
1276 
1277   /*   Now assemble the off proc rows*/
1278   {
1279     int    *sbuf1_i,*rbuf2_i,*rbuf3_i,*imat_ilen,ilen;
1280     int    *imat_j,*imat_i;
1281     Scalar *imat_a,*rbuf4_i;
1282 
1283     for (tmp2=0; tmp2<nrqs; tmp2++) {
1284       MPI_Waitany(nrqs, r_waits4, &i, r_status4+tmp2);
1285       index   = pa[i];
1286       sbuf1_i = sbuf1[index];
1287       jmax    = sbuf1_i[0];
1288       ct1     = 2*jmax + 1;
1289       ct2     = 0;
1290       rbuf2_i = rbuf2[i];
1291       rbuf3_i = rbuf3[i];
1292       rbuf4_i = rbuf4[i];
1293       for (j=1; j<=jmax; j++) {
1294         is_no     = sbuf1_i[2*j-1];
1295         rmap_i    = rmap[is_no];
1296         cmap_i    = cmap[is_no];
1297         mat       = (Mat_SeqBAIJ *) submats[is_no]->data;
1298         imat_ilen = mat->ilen;
1299         imat_j    = mat->j;
1300         imat_i    = mat->i;
1301         imat_a    = mat->a;
1302         max1      = sbuf1_i[2*j];
1303         for (k=0; k<max1; k++, ct1++) {
1304           row   = sbuf1_i[ct1];
1305           row   = rmap_i[row];
1306           ilen  = imat_ilen[row];
1307           mat_i = imat_i[row];
1308           mat_a = imat_a + mat_i*bs2;
1309           mat_j = imat_j + mat_i;
1310           max2 = rbuf2_i[ct1];
1311           for (l=0; l<max2; l++,ct2++) {
1312             if ((tcol = cmap_i[rbuf3_i[ct2]])) {
1313               *mat_j++ = tcol - 1;
1314               /* *mat_a++ = rbuf4_i[ct2]; */
1315               PetscMemcpy(mat_a,rbuf4_i+ct2*bs2,bs2*sizeof(Scalar)); mat_a += bs2;
1316               ilen++;
1317             }
1318           }
1319           imat_ilen[row] = ilen;
1320         }
1321       }
1322     }
1323   }
1324   PetscFree(r_status4); PetscFree(r_waits4);
1325   MPI_Waitall(nrqr,s_waits4,s_status4);
1326   PetscFree(s_waits4); PetscFree(s_status4);
1327 
1328   /* Restore the indices */
1329   for (i=0; i<ismax; i++) {
1330     ierr = ISRestoreIndices(isrow[i], irow+i); CHKERRQ(ierr);
1331     ierr = ISRestoreIndices(iscol[i], icol+i); CHKERRQ(ierr);
1332   }
1333 
1334   /* Destroy allocated memory */
1335   PetscFree(irow);
1336   PetscFree(w1);
1337   PetscFree(pa);
1338 
1339   PetscFree(sbuf1);
1340   PetscFree(rbuf2);
1341   for (i=0; i<nrqr; ++i) {
1342     PetscFree(sbuf2[i]);
1343   }
1344   for (i=0; i<nrqs; ++i) {
1345     PetscFree(rbuf3[i]);
1346     PetscFree(rbuf4[i]);
1347   }
1348 
1349   PetscFree(sbuf2);
1350   PetscFree(rbuf3);
1351   PetscFree(rbuf4 );
1352   PetscFree(sbuf_aj[0]);
1353   PetscFree(sbuf_aj);
1354   PetscFree(sbuf_aa[0]);
1355   PetscFree(sbuf_aa);
1356 
1357   PetscFree(cmap);
1358   PetscFree(rmap);
1359   PetscFree(lens);
1360 
1361   for (i=0; i<ismax; i++) {
1362     ierr = MatAssemblyBegin(submats[i], MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
1363     ierr = MatAssemblyEnd(submats[i], MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
1364   }
1365 
1366   ierr = PetscObjectRestoreNewTag((PetscObject)C,&tag3); CHKERRQ(ierr);
1367   ierr = PetscObjectRestoreNewTag((PetscObject)C,&tag2); CHKERRQ(ierr);
1368   ierr = PetscObjectRestoreNewTag((PetscObject)C,&tag1); CHKERRQ(ierr);
1369 
1370   PetscFunctionReturn(0);
1371 }
1372