PetscErrorCode AOView_MemoryScalable(AO ao,PetscViewer viewer)
{
PetscErrorCode ierr;
PetscMPIInt rank,size;
AO_MemoryScalable *aomems = (AO_MemoryScalable*)ao->data;
PetscBool iascii;
PetscMPIInt tag_app,tag_petsc;
PetscLayout map = aomems->map;
PetscInt *app,*app_loc,*petsc,*petsc_loc,len,i,j;
MPI_Status status;
PetscFunctionBegin;
ierr = PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&iascii);CHKERRQ(ierr);
if (!iascii) SETERRQ1(PetscObjectComm((PetscObject)viewer),PETSC_ERR_SUP,"Viewer type %s not supported for AO MemoryScalable",((PetscObject)viewer)->type_name);
ierr = MPI_Comm_rank(PetscObjectComm((PetscObject)ao),&rank);CHKERRQ(ierr);
ierr = MPI_Comm_size(PetscObjectComm((PetscObject)ao),&size);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)ao,&tag_app);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)ao,&tag_petsc);CHKERRQ(ierr);
if (!rank) {
ierr = PetscViewerASCIIPrintf(viewer,"Number of elements in ordering %D\n",ao->N);CHKERRQ(ierr);
ierr = PetscViewerASCIIPrintf(viewer, "PETSc->App App->PETSc\n");CHKERRQ(ierr);
ierr = PetscMalloc2(map->N,&app,map->N,&petsc);CHKERRQ(ierr);
len = map->n;
/* print local AO */
ierr = PetscViewerASCIIPrintf(viewer,"Process [%D]\n",rank);CHKERRQ(ierr);
for (i=0; i<len; i++) {
ierr = PetscViewerASCIIPrintf(viewer,"%3D %3D %3D %3D\n",i,aomems->app_loc[i],i,aomems->petsc_loc[i]);CHKERRQ(ierr);
}
/* recv and print off-processor's AO */
for (i=1; i<size; i++) {
len = map->range[i+1] - map->range[i];
app_loc = app + map->range[i];
petsc_loc = petsc+ map->range[i];
ierr = MPI_Recv(app_loc,(PetscMPIInt)len,MPIU_INT,i,tag_app,PetscObjectComm((PetscObject)ao),&status);CHKERRQ(ierr);
ierr = MPI_Recv(petsc_loc,(PetscMPIInt)len,MPIU_INT,i,tag_petsc,PetscObjectComm((PetscObject)ao),&status);CHKERRQ(ierr);
ierr = PetscViewerASCIIPrintf(viewer,"Process [%D]\n",i);CHKERRQ(ierr);
for (j=0; j<len; j++) {
ierr = PetscViewerASCIIPrintf(viewer,"%3D %3D %3D %3D\n",map->range[i]+j,app_loc[j],map->range[i]+j,petsc_loc[j]);CHKERRQ(ierr);
}
}
ierr = PetscFree2(app,petsc);CHKERRQ(ierr);
} else {
/* send values */
ierr = MPI_Send((void*)aomems->app_loc,map->n,MPIU_INT,0,tag_app,PetscObjectComm((PetscObject)ao));CHKERRQ(ierr);
ierr = MPI_Send((void*)aomems->petsc_loc,map->n,MPIU_INT,0,tag_petsc,PetscObjectComm((PetscObject)ao));CHKERRQ(ierr);
}
ierr = PetscViewerFlush(viewer);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode VecView_MPI_Draw_DA1d(Vec xin,PetscViewer v)
{
DM da;
PetscErrorCode ierr;
PetscMPIInt rank,size,tag1,tag2;
PetscInt i,n,N,step,istart,isize,j,nbounds;
MPI_Status status;
PetscReal coors[4],ymin,ymax,min,max,xmin = 0.0,xmax = 0.0,tmp = 0.0,xgtmp = 0.0;
const PetscScalar *array,*xg;
PetscDraw draw;
PetscBool isnull,showpoints = PETSC_FALSE;
MPI_Comm comm;
PetscDrawAxis axis;
Vec xcoor;
DMBoundaryType bx;
const PetscReal *bounds;
PetscInt *displayfields;
PetscInt k,ndisplayfields;
PetscBool hold;
PetscFunctionBegin;
ierr = PetscViewerDrawGetDraw(v,0,&draw);CHKERRQ(ierr);
ierr = PetscDrawIsNull(draw,&isnull);CHKERRQ(ierr); if (isnull) PetscFunctionReturn(0);
ierr = PetscViewerDrawGetBounds(v,&nbounds,&bounds);CHKERRQ(ierr);
ierr = VecGetDM(xin,&da);CHKERRQ(ierr);
if (!da) SETERRQ(PetscObjectComm((PetscObject)xin),PETSC_ERR_ARG_WRONG,"Vector not generated from a DMDA");
ierr = PetscOptionsGetBool(NULL,"-draw_vec_mark_points",&showpoints,NULL);CHKERRQ(ierr);
ierr = DMDAGetInfo(da,0,&N,0,0,0,0,0,&step,0,&bx,0,0,0);CHKERRQ(ierr);
ierr = DMDAGetCorners(da,&istart,0,0,&isize,0,0);CHKERRQ(ierr);
ierr = VecGetArrayRead(xin,&array);CHKERRQ(ierr);
ierr = VecGetLocalSize(xin,&n);CHKERRQ(ierr);
n = n/step;
/* get coordinates of nodes */
ierr = DMGetCoordinates(da,&xcoor);CHKERRQ(ierr);
if (!xcoor) {
ierr = DMDASetUniformCoordinates(da,0.0,1.0,0.0,0.0,0.0,0.0);CHKERRQ(ierr);
ierr = DMGetCoordinates(da,&xcoor);CHKERRQ(ierr);
}
ierr = VecGetArrayRead(xcoor,&xg);CHKERRQ(ierr);
ierr = PetscObjectGetComm((PetscObject)xin,&comm);CHKERRQ(ierr);
ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);CHKERRQ(ierr);
/*
Determine the min and max x coordinate in plot
*/
if (!rank) {
xmin = PetscRealPart(xg[0]);
}
if (rank == size-1) {
xmax = PetscRealPart(xg[n-1]);
}
ierr = MPI_Bcast(&xmin,1,MPIU_REAL,0,comm);CHKERRQ(ierr);
ierr = MPI_Bcast(&xmax,1,MPIU_REAL,size-1,comm);CHKERRQ(ierr);
ierr = DMDASelectFields(da,&ndisplayfields,&displayfields);CHKERRQ(ierr);
for (k=0; k<ndisplayfields; k++) {
j = displayfields[k];
ierr = PetscViewerDrawGetDraw(v,k,&draw);CHKERRQ(ierr);
ierr = PetscDrawCheckResizedWindow(draw);CHKERRQ(ierr);
/*
Determine the min and max y coordinate in plot
*/
min = 1.e20; max = -1.e20;
for (i=0; i<n; i++) {
if (PetscRealPart(array[j+i*step]) < min) min = PetscRealPart(array[j+i*step]);
if (PetscRealPart(array[j+i*step]) > max) max = PetscRealPart(array[j+i*step]);
}
if (min + 1.e-10 > max) {
min -= 1.e-5;
max += 1.e-5;
}
if (j < nbounds) {
min = PetscMin(min,bounds[2*j]);
max = PetscMax(max,bounds[2*j+1]);
}
ierr = MPI_Reduce(&min,&ymin,1,MPIU_REAL,MPIU_MIN,0,comm);CHKERRQ(ierr);
ierr = MPI_Reduce(&max,&ymax,1,MPIU_REAL,MPIU_MAX,0,comm);CHKERRQ(ierr);
ierr = PetscViewerDrawGetHold(v,&hold);CHKERRQ(ierr);
if (!hold) {
ierr = PetscDrawSynchronizedClear(draw);CHKERRQ(ierr);
}
ierr = PetscViewerDrawGetDrawAxis(v,k,&axis);CHKERRQ(ierr);
ierr = PetscLogObjectParent((PetscObject)draw,(PetscObject)axis);CHKERRQ(ierr);
if (!rank) {
const char *title;
ierr = PetscDrawAxisSetLimits(axis,xmin,xmax,ymin,ymax);CHKERRQ(ierr);
ierr = PetscDrawAxisDraw(axis);CHKERRQ(ierr);
ierr = PetscDrawGetCoordinates(draw,coors,coors+1,coors+2,coors+3);CHKERRQ(ierr);
ierr = DMDAGetFieldName(da,j,&title);CHKERRQ(ierr);
if (title) {ierr = PetscDrawSetTitle(draw,title);CHKERRQ(ierr);}
}
ierr = MPI_Bcast(coors,4,MPIU_REAL,0,comm);CHKERRQ(ierr);
if (rank) {
ierr = PetscDrawSetCoordinates(draw,coors[0],coors[1],coors[2],coors[3]);CHKERRQ(ierr);
}
/* draw local part of vector */
ierr = PetscObjectGetNewTag((PetscObject)xin,&tag1);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)xin,&tag2);CHKERRQ(ierr);
if (rank < size-1) { /*send value to right */
ierr = MPI_Send((void*)&array[j+(n-1)*step],1,MPIU_REAL,rank+1,tag1,comm);CHKERRQ(ierr);
ierr = MPI_Send((void*)&xg[n-1],1,MPIU_REAL,rank+1,tag1,comm);CHKERRQ(ierr);
}
if (!rank && bx == DM_BOUNDARY_PERIODIC && size > 1) { /* first processor sends first value to last */
ierr = MPI_Send((void*)&array[j],1,MPIU_REAL,size-1,tag2,comm);CHKERRQ(ierr);
}
for (i=1; i<n; i++) {
ierr = PetscDrawLine(draw,PetscRealPart(xg[i-1]),PetscRealPart(array[j+step*(i-1)]),PetscRealPart(xg[i]),PetscRealPart(array[j+step*i]),PETSC_DRAW_RED);CHKERRQ(ierr);
if (showpoints) {
ierr = PetscDrawPoint(draw,PetscRealPart(xg[i-1]),PetscRealPart(array[j+step*(i-1)]),PETSC_DRAW_BLACK);CHKERRQ(ierr);
}
}
if (rank) { /* receive value from left */
ierr = MPI_Recv(&tmp,1,MPIU_REAL,rank-1,tag1,comm,&status);CHKERRQ(ierr);
ierr = MPI_Recv(&xgtmp,1,MPIU_REAL,rank-1,tag1,comm,&status);CHKERRQ(ierr);
ierr = PetscDrawLine(draw,xgtmp,tmp,PetscRealPart(xg[0]),PetscRealPart(array[j]),PETSC_DRAW_RED);CHKERRQ(ierr);
if (showpoints) {
ierr = PetscDrawPoint(draw,xgtmp,tmp,PETSC_DRAW_BLACK);CHKERRQ(ierr);
}
}
if (rank == size-1 && bx == DM_BOUNDARY_PERIODIC && size > 1) {
ierr = MPI_Recv(&tmp,1,MPIU_REAL,0,tag2,comm,&status);CHKERRQ(ierr);
/* If the mesh is not uniform we do not know the mesh spacing between the last point on the right and the first ghost point */
ierr = PetscDrawLine(draw,PetscRealPart(xg[n-1]),PetscRealPart(array[j+step*(n-1)]),PetscRealPart(xg[n-1]+(xg[n-1]-xg[n-2])),tmp,PETSC_DRAW_RED);CHKERRQ(ierr);
if (showpoints) {
ierr = PetscDrawPoint(draw,PetscRealPart(xg[n-2]),PetscRealPart(array[j+step*(n-1)]),PETSC_DRAW_BLACK);CHKERRQ(ierr);
}
}
ierr = PetscDrawSynchronizedFlush(draw);CHKERRQ(ierr);
ierr = PetscDrawPause(draw);CHKERRQ(ierr);
}
ierr = PetscFree(displayfields);CHKERRQ(ierr);
ierr = VecRestoreArrayRead(xcoor,&xg);CHKERRQ(ierr);
ierr = VecRestoreArrayRead(xin,&array);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode AOCreateMemoryScalable_private(MPI_Comm comm,PetscInt napp,const PetscInt from_array[],const PetscInt to_array[],AO ao, PetscInt *aomap_loc)
{
PetscErrorCode ierr;
AO_MemoryScalable *aomems = (AO_MemoryScalable*)ao->data;
PetscLayout map = aomems->map;
PetscInt n_local = map->n,i,j;
PetscMPIInt rank,size,tag;
PetscInt *owner,*start,*nprocs,nsends,nreceives;
PetscInt nmax,count,*sindices,*rindices,idx,lastidx;
PetscInt *owners = aomems->map->range;
MPI_Request *send_waits,*recv_waits;
MPI_Status recv_status;
PetscMPIInt nindices,widx;
PetscInt *rbuf;
PetscInt n=napp,ip,ia;
MPI_Status *send_status;
PetscFunctionBegin;
ierr = PetscMemzero(aomap_loc,n_local*sizeof(PetscInt));
CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);
CHKERRQ(ierr);
ierr = MPI_Comm_size(comm,&size);
CHKERRQ(ierr);
/* first count number of contributors (of from_array[]) to each processor */
ierr = PetscMalloc(2*size*sizeof(PetscInt),&nprocs);
CHKERRQ(ierr);
ierr = PetscMemzero(nprocs,2*size*sizeof(PetscInt));
CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscInt),&owner);
CHKERRQ(ierr);
j = 0;
lastidx = -1;
for (i=0; i<n; i++) {
/* if indices are NOT locally sorted, need to start search at the beginning */
if (lastidx > (idx = from_array[i])) j = 0;
lastidx = idx;
for (; j<size; j++) {
if (idx >= owners[j] && idx < owners[j+1]) {
nprocs[2*j] += 2; /* num of indices to be sent - in pairs (ip,ia) */
nprocs[2*j+1] = 1; /* send to proc[j] */
owner[i] = j;
break;
}
}
}
nprocs[2*rank]=nprocs[2*rank+1]=0; /* do not receive from self! */
nsends = 0;
for (i=0; i<size; i++) nsends += nprocs[2*i+1];
/* inform other processors of number of messages and max length*/
ierr = PetscMaxSum(comm,nprocs,&nmax,&nreceives);
CHKERRQ(ierr);
/* allocate arrays */
ierr = PetscObjectGetNewTag((PetscObject)ao,&tag);
CHKERRQ(ierr);
ierr = PetscMalloc2(nreceives*nmax,PetscInt,&rindices,nreceives,MPI_Request,&recv_waits);
CHKERRQ(ierr);
ierr = PetscMalloc3(2*n,PetscInt,&sindices,nsends,MPI_Request,&send_waits,nsends,MPI_Status,&send_status);
CHKERRQ(ierr);
ierr = PetscMalloc(size*sizeof(PetscInt),&start);
CHKERRQ(ierr);
/* post receives: */
for (i=0; i<nreceives; i++) {
ierr = MPI_Irecv(rindices+nmax*i,nmax,MPIU_INT,MPI_ANY_SOURCE,tag,comm,recv_waits+i);
CHKERRQ(ierr);
}
/* do sends:
1) starts[i] gives the starting index in svalues for stuff going to
the ith processor
*/
start[0] = 0;
for (i=1; i<size; i++) start[i] = start[i-1] + nprocs[2*i-2];
for (i=0; i<n; i++) {
j = owner[i];
if (j != rank) {
ip = from_array[i];
ia = to_array[i];
sindices[start[j]++] = ip;
sindices[start[j]++] = ia;
} else { /* compute my own map */
ip = from_array[i] - owners[rank];
ia = to_array[i];
aomap_loc[ip] = ia;
}
}
start[0] = 0;
for (i=1; i<size; i++) start[i] = start[i-1] + nprocs[2*i-2];
for (i=0,count=0; i<size; i++) {
if (nprocs[2*i+1]) {
ierr = MPI_Isend(sindices+start[i],nprocs[2*i],MPIU_INT,i,tag,comm,send_waits+count);
CHKERRQ(ierr);
count++;
}
}
if (nsends != count) SETERRQ2(comm,PETSC_ERR_SUP,"nsends %d != count %d",nsends,count);
/* wait on sends */
if (nsends) {
ierr = MPI_Waitall(nsends,send_waits,send_status);
CHKERRQ(ierr);
}
/* recvs */
count=0;
for (j= nreceives; j>0; j--) {
ierr = MPI_Waitany(nreceives,recv_waits,&widx,&recv_status);
CHKERRQ(ierr);
ierr = MPI_Get_count(&recv_status,MPIU_INT,&nindices);
CHKERRQ(ierr);
rbuf = rindices+nmax*widx; /* global index */
/* compute local mapping */
for (i=0; i<nindices; i+=2) { /* pack aomap_loc */
ip = rbuf[i] - owners[rank]; /* local index */
ia = rbuf[i+1];
aomap_loc[ip] = ia;
}
count++;
}
ierr = PetscFree(start);
CHKERRQ(ierr);
ierr = PetscFree3(sindices,send_waits,send_status);
CHKERRQ(ierr);
ierr = PetscFree2(rindices,recv_waits);
CHKERRQ(ierr);
ierr = PetscFree(owner);
CHKERRQ(ierr);
ierr = PetscFree(nprocs);
CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode AOMap_MemoryScalable_private(AO ao,PetscInt n,PetscInt *ia,PetscInt *maploc)
{
PetscErrorCode ierr;
AO_MemoryScalable *aomems = (AO_MemoryScalable*)ao->data;
MPI_Comm comm;
PetscMPIInt rank,size,tag1,tag2;
PetscInt *owner,*start,*nprocs,nsends,nreceives;
PetscInt nmax,count,*sindices,*rindices,i,j,idx,lastidx,*sindices2,*rindices2;
PetscInt *owners = aomems->map->range;
MPI_Request *send_waits,*recv_waits,*send_waits2,*recv_waits2;
MPI_Status recv_status;
PetscMPIInt nindices,source,widx;
PetscInt *rbuf,*sbuf;
MPI_Status *send_status,*send_status2;
PetscFunctionBegin;
ierr = PetscObjectGetComm((PetscObject)ao,&comm);
CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);
CHKERRQ(ierr);
ierr = MPI_Comm_size(comm,&size);
CHKERRQ(ierr);
/* first count number of contributors to each processor */
ierr = PetscMalloc2(2*size,PetscInt,&nprocs,size,PetscInt,&start);
CHKERRQ(ierr);
ierr = PetscMemzero(nprocs,2*size*sizeof(PetscInt));
CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscInt),&owner);
CHKERRQ(ierr);
ierr = PetscMemzero(owner,n*sizeof(PetscInt));
CHKERRQ(ierr);
j = 0;
lastidx = -1;
for (i=0; i<n; i++) {
/* if indices are NOT locally sorted, need to start search at the beginning */
if (lastidx > (idx = ia[i])) j = 0;
lastidx = idx;
for (; j<size; j++) {
if (idx >= owners[j] && idx < owners[j+1]) {
nprocs[2*j]++; /* num of indices to be sent */
nprocs[2*j+1] = 1; /* send to proc[j] */
owner[i] = j;
break;
}
}
}
nprocs[2*rank]=nprocs[2*rank+1]=0; /* do not receive from self! */
nsends = 0;
for (i=0; i<size; i++) nsends += nprocs[2*i+1];
/* inform other processors of number of messages and max length*/
ierr = PetscMaxSum(comm,nprocs,&nmax,&nreceives);
CHKERRQ(ierr);
/* allocate arrays */
ierr = PetscObjectGetNewTag((PetscObject)ao,&tag1);
CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)ao,&tag2);
CHKERRQ(ierr);
ierr = PetscMalloc2(nreceives*nmax,PetscInt,&rindices,nreceives,MPI_Request,&recv_waits);
CHKERRQ(ierr);
ierr = PetscMalloc2(nsends*nmax,PetscInt,&rindices2,nsends,MPI_Request,&recv_waits2);
CHKERRQ(ierr);
ierr = PetscMalloc3(n,PetscInt,&sindices,nsends,MPI_Request,&send_waits,nsends,MPI_Status,&send_status);
CHKERRQ(ierr);
ierr = PetscMalloc3(n,PetscInt,&sindices2,nreceives,MPI_Request,&send_waits2,nreceives,MPI_Status,&send_status2);
CHKERRQ(ierr);
/* post 1st receives: receive others requests
since we don't know how long each individual message is we
allocate the largest needed buffer for each receive. Potentially
this is a lot of wasted space.
*/
for (i=0,count=0; i<nreceives; i++) {
ierr = MPI_Irecv(rindices+nmax*i,nmax,MPIU_INT,MPI_ANY_SOURCE,tag1,comm,recv_waits+count++);
CHKERRQ(ierr);
}
/* do 1st sends:
1) starts[i] gives the starting index in svalues for stuff going to
the ith processor
*/
start[0] = 0;
for (i=1; i<size; i++) start[i] = start[i-1] + nprocs[2*i-2];
for (i=0; i<n; i++) {
j = owner[i];
if (j != rank) {
sindices[start[j]++] = ia[i];
} else { /* compute my own map */
if (ia[i] >= owners[rank] && ia[i] < owners[rank+1]) {
ia[i] = maploc[ia[i]-owners[rank]];
} else {
ia[i] = -1; /* ia[i] is not in the range of 0 and N-1, maps it to -1 */
}
}
}
start[0] = 0;
for (i=1; i<size; i++) start[i] = start[i-1] + nprocs[2*i-2];
for (i=0,count=0; i<size; i++) {
if (nprocs[2*i+1]) {
/* send my request to others */
ierr = MPI_Isend(sindices+start[i],nprocs[2*i],MPIU_INT,i,tag1,comm,send_waits+count);
CHKERRQ(ierr);
/* post receive for the answer of my request */
ierr = MPI_Irecv(sindices2+start[i],nprocs[2*i],MPIU_INT,i,tag2,comm,recv_waits2+count);
CHKERRQ(ierr);
count++;
}
}
if (nsends != count) SETERRQ2(comm,PETSC_ERR_SUP,"nsends %d != count %d",nsends,count);
/* wait on 1st sends */
if (nsends) {
ierr = MPI_Waitall(nsends,send_waits,send_status);
CHKERRQ(ierr);
}
/* 1st recvs: other's requests */
for (j=0; j< nreceives; j++) {
ierr = MPI_Waitany(nreceives,recv_waits,&widx,&recv_status);
CHKERRQ(ierr); /* idx: index of handle for operation that completed */
ierr = MPI_Get_count(&recv_status,MPIU_INT,&nindices);
CHKERRQ(ierr);
rbuf = rindices+nmax*widx; /* global index */
source = recv_status.MPI_SOURCE;
/* compute mapping */
sbuf = rbuf;
for (i=0; i<nindices; i++) sbuf[i] = maploc[rbuf[i]-owners[rank]];
/* send mapping back to the sender */
ierr = MPI_Isend(sbuf,nindices,MPIU_INT,source,tag2,comm,send_waits2+widx);
CHKERRQ(ierr);
}
/* wait on 2nd sends */
if (nreceives) {
ierr = MPI_Waitall(nreceives,send_waits2,send_status2);
CHKERRQ(ierr);
}
/* 2nd recvs: for the answer of my request */
for (j=0; j< nsends; j++) {
ierr = MPI_Waitany(nsends,recv_waits2,&widx,&recv_status);
CHKERRQ(ierr);
ierr = MPI_Get_count(&recv_status,MPIU_INT,&nindices);
CHKERRQ(ierr);
source = recv_status.MPI_SOURCE;
/* pack output ia[] */
rbuf = sindices2+start[source];
count = 0;
for (i=0; i<n; i++) {
if (source == owner[i]) ia[i] = rbuf[count++];
}
}
/* free arrays */
ierr = PetscFree2(nprocs,start);
CHKERRQ(ierr);
ierr = PetscFree(owner);
CHKERRQ(ierr);
ierr = PetscFree2(rindices,recv_waits);
CHKERRQ(ierr);
ierr = PetscFree2(rindices2,recv_waits2);
CHKERRQ(ierr);
ierr = PetscFree3(sindices,send_waits,send_status);
CHKERRQ(ierr);
ierr = PetscFree3(sindices2,send_waits2,send_status2);
CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode VecLoad_Binary(Vec vec, PetscViewer viewer)
{
PetscMPIInt size,rank,tag;
int fd;
PetscInt i,rows = 0,n,*range,N,bs;
PetscErrorCode ierr;
PetscBool flag;
PetscScalar *avec,*avecwork;
MPI_Comm comm;
MPI_Request request;
MPI_Status status;
#if defined(PETSC_HAVE_MPIIO)
PetscBool useMPIIO;
#endif
PetscFunctionBegin;
ierr = PetscObjectGetComm((PetscObject)viewer,&comm);CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);CHKERRQ(ierr);
ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr);
ierr = PetscViewerBinaryGetDescriptor(viewer,&fd);CHKERRQ(ierr);
ierr = PetscViewerBinaryReadVecHeader_Private(viewer,&rows);CHKERRQ(ierr);
/* Set Vec sizes,blocksize,and type if not already set. Block size first so that local sizes will be compatible. */
ierr = PetscOptionsGetInt(((PetscObject)vec)->prefix, "-vecload_block_size", &bs, &flag);CHKERRQ(ierr);
if (flag) {
ierr = VecSetBlockSize(vec, bs);CHKERRQ(ierr);
}
if (vec->map->n < 0 && vec->map->N < 0) {
ierr = VecSetSizes(vec,PETSC_DECIDE,rows);CHKERRQ(ierr);
}
/* If sizes and type already set,check if the vector global size is correct */
ierr = VecGetSize(vec, &N);CHKERRQ(ierr);
if (N != rows) SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_FILE_UNEXPECTED, "Vector in file different length (%d) then input vector (%d)", rows, N);
#if defined(PETSC_HAVE_MPIIO)
ierr = PetscViewerBinaryGetMPIIO(viewer,&useMPIIO);CHKERRQ(ierr);
if (useMPIIO) {
ierr = VecLoad_Binary_MPIIO(vec, viewer);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
#endif
ierr = VecGetLocalSize(vec,&n);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)viewer,&tag);CHKERRQ(ierr);
ierr = VecGetArray(vec,&avec);CHKERRQ(ierr);
if (!rank) {
ierr = PetscBinaryRead(fd,avec,n,PETSC_SCALAR);CHKERRQ(ierr);
if (size > 1) {
/* read in other chuncks and send to other processors */
/* determine maximum chunck owned by other */
range = vec->map->range;
n = 1;
for (i=1; i<size; i++) n = PetscMax(n,range[i+1] - range[i]);
ierr = PetscMalloc(n*sizeof(PetscScalar),&avecwork);CHKERRQ(ierr);
for (i=1; i<size; i++) {
n = range[i+1] - range[i];
ierr = PetscBinaryRead(fd,avecwork,n,PETSC_SCALAR);CHKERRQ(ierr);
ierr = MPI_Isend(avecwork,n,MPIU_SCALAR,i,tag,comm,&request);CHKERRQ(ierr);
ierr = MPI_Wait(&request,&status);CHKERRQ(ierr);
}
ierr = PetscFree(avecwork);CHKERRQ(ierr);
}
} else {
ierr = MPI_Recv(avec,n,MPIU_SCALAR,0,tag,comm,&status);CHKERRQ(ierr);
}
ierr = VecRestoreArray(vec,&avec);CHKERRQ(ierr);
ierr = VecAssemblyBegin(vec);CHKERRQ(ierr);
ierr = VecAssemblyEnd(vec);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
static PetscErrorCode MatIncreaseOverlap_MPISBAIJ_Once(Mat C,PetscInt is_max,IS is[])
{
Mat_MPISBAIJ *c = (Mat_MPISBAIJ*)C->data;
PetscErrorCode ierr;
PetscMPIInt size,rank,tag1,tag2,*len_s,nrqr,nrqs,*id_r1,*len_r1,flag,len;
const PetscInt *idx_i;
PetscInt idx,isz,col,*n,*data1,**data1_start,*data2,*data2_i,*data,*data_i,
Mbs,i,j,k,*odata1,*odata2,
proc_id,**odata2_ptr,*ctable=0,*btable,len_max,len_est;
PetscInt proc_end=0,*iwork,len_unused,nodata2;
PetscInt ois_max; /* max no of is[] in each of processor */
char *t_p;
MPI_Comm comm;
MPI_Request *s_waits1,*s_waits2,r_req;
MPI_Status *s_status,r_status;
PetscBT *table; /* mark indices of this processor's is[] */
PetscBT table_i;
PetscBT otable; /* mark indices of other processors' is[] */
PetscInt bs=C->rmap->bs,Bn = c->B->cmap->n,Bnbs = Bn/bs,*Bowners;
IS garray_local,garray_gl;
PetscFunctionBegin;
comm = ((PetscObject)C)->comm;
size = c->size;
rank = c->rank;
Mbs = c->Mbs;
ierr = PetscObjectGetNewTag((PetscObject)C,&tag1);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)C,&tag2);CHKERRQ(ierr);
/* create tables used in
step 1: table[i] - mark c->garray of proc [i]
step 3: table[i] - mark indices of is[i] when whose=MINE
table[0] - mark incideces of is[] when whose=OTHER */
len = PetscMax(is_max, size);CHKERRQ(ierr);
ierr = PetscMalloc2(len,PetscBT,&table,(Mbs/PETSC_BITS_PER_BYTE+1)*len,char,&t_p);CHKERRQ(ierr);
for (i=0; i<len; i++) {
table[i] = t_p + (Mbs/PETSC_BITS_PER_BYTE+1)*i;
}
ierr = MPI_Allreduce(&is_max,&ois_max,1,MPIU_INT,MPI_MAX,comm);CHKERRQ(ierr);
/* 1. Send this processor's is[] to other processors */
/*---------------------------------------------------*/
/* allocate spaces */
ierr = PetscMalloc(is_max*sizeof(PetscInt),&n);CHKERRQ(ierr);
len = 0;
for (i=0; i<is_max; i++) {
ierr = ISGetLocalSize(is[i],&n[i]);CHKERRQ(ierr);
len += n[i];
}
if (!len) {
is_max = 0;
} else {
len += 1 + is_max; /* max length of data1 for one processor */
}
ierr = PetscMalloc((size*len+1)*sizeof(PetscInt),&data1);CHKERRQ(ierr);
ierr = PetscMalloc(size*sizeof(PetscInt*),&data1_start);CHKERRQ(ierr);
for (i=0; i<size; i++) data1_start[i] = data1 + i*len;
ierr = PetscMalloc4(size,PetscInt,&len_s,size,PetscInt,&btable,size,PetscInt,&iwork,size+1,PetscInt,&Bowners);CHKERRQ(ierr);
/* gather c->garray from all processors */
ierr = ISCreateGeneral(comm,Bnbs,c->garray,&garray_local);CHKERRQ(ierr);
ierr = ISAllGather(garray_local, &garray_gl);CHKERRQ(ierr);
ierr = ISDestroy(garray_local);CHKERRQ(ierr);
ierr = MPI_Allgather(&Bnbs,1,MPIU_INT,Bowners+1,1,MPIU_INT,comm);CHKERRQ(ierr);
Bowners[0] = 0;
for (i=0; i<size; i++) Bowners[i+1] += Bowners[i];
if (is_max){
/* hash table ctable which maps c->row to proc_id) */
ierr = PetscMalloc(Mbs*sizeof(PetscInt),&ctable);CHKERRQ(ierr);
for (proc_id=0,j=0; proc_id<size; proc_id++) {
for (; j<C->rmap->range[proc_id+1]/bs; j++) {
ctable[j] = proc_id;
}
}
/* hash tables marking c->garray */
ierr = ISGetIndices(garray_gl,&idx_i);
for (i=0; i<size; i++){
table_i = table[i];
ierr = PetscBTMemzero(Mbs,table_i);CHKERRQ(ierr);
for (j = Bowners[i]; j<Bowners[i+1]; j++){ /* go through B cols of proc[i]*/
ierr = PetscBTSet(table_i,idx_i[j]);CHKERRQ(ierr);
}
}
ierr = ISRestoreIndices(garray_gl,&idx_i);CHKERRQ(ierr);
} /* if (is_max) */
ierr = ISDestroy(garray_gl);CHKERRQ(ierr);
/* evaluate communication - mesg to who, length, and buffer space */
for (i=0; i<size; i++) len_s[i] = 0;
/* header of data1 */
for (proc_id=0; proc_id<size; proc_id++){
iwork[proc_id] = 0;
*data1_start[proc_id] = is_max;
data1_start[proc_id]++;
for (j=0; j<is_max; j++) {
if (proc_id == rank){
*data1_start[proc_id] = n[j];
} else {
*data1_start[proc_id] = 0;
}
data1_start[proc_id]++;
}
}
for (i=0; i<is_max; i++) {
ierr = ISGetIndices(is[i],&idx_i);CHKERRQ(ierr);
for (j=0; j<n[i]; j++){
idx = idx_i[j];
*data1_start[rank] = idx; data1_start[rank]++; /* for local proccessing */
proc_end = ctable[idx];
for (proc_id=0; proc_id<=proc_end; proc_id++){ /* for others to process */
if (proc_id == rank ) continue; /* done before this loop */
if (proc_id < proc_end && !PetscBTLookup(table[proc_id],idx))
continue; /* no need for sending idx to [proc_id] */
*data1_start[proc_id] = idx; data1_start[proc_id]++;
len_s[proc_id]++;
}
}
/* update header data */
for (proc_id=0; proc_id<size; proc_id++){
if (proc_id== rank) continue;
*(data1 + proc_id*len + 1 + i) = len_s[proc_id] - iwork[proc_id];
iwork[proc_id] = len_s[proc_id] ;
}
ierr = ISRestoreIndices(is[i],&idx_i);CHKERRQ(ierr);
}
nrqs = 0; nrqr = 0;
for (i=0; i<size; i++){
data1_start[i] = data1 + i*len;
if (len_s[i]){
nrqs++;
len_s[i] += 1 + is_max; /* add no. of header msg */
}
}
for (i=0; i<is_max; i++) {
ierr = ISDestroy(is[i]);CHKERRQ(ierr);
}
ierr = PetscFree(n);CHKERRQ(ierr);
ierr = PetscFree(ctable);CHKERRQ(ierr);
/* Determine the number of messages to expect, their lengths, from from-ids */
ierr = PetscGatherNumberOfMessages(comm,PETSC_NULL,len_s,&nrqr);CHKERRQ(ierr);
ierr = PetscGatherMessageLengths(comm,nrqs,nrqr,len_s,&id_r1,&len_r1);CHKERRQ(ierr);
/* Now post the sends */
ierr = PetscMalloc2(size,MPI_Request,&s_waits1,size,MPI_Request,&s_waits2);CHKERRQ(ierr);
k = 0;
for (proc_id=0; proc_id<size; proc_id++){ /* send data1 to processor [proc_id] */
if (len_s[proc_id]){
ierr = MPI_Isend(data1_start[proc_id],len_s[proc_id],MPIU_INT,proc_id,tag1,comm,s_waits1+k);CHKERRQ(ierr);
k++;
}
}
/* 2. Receive other's is[] and process. Then send back */
/*-----------------------------------------------------*/
len = 0;
for (i=0; i<nrqr; i++){
if (len_r1[i] > len)len = len_r1[i];
}
ierr = PetscFree(len_r1);CHKERRQ(ierr);
ierr = PetscFree(id_r1);CHKERRQ(ierr);
for (proc_id=0; proc_id<size; proc_id++)
len_s[proc_id] = iwork[proc_id] = 0;
ierr = PetscMalloc((len+1)*sizeof(PetscInt),&odata1);CHKERRQ(ierr);
ierr = PetscMalloc(size*sizeof(PetscInt**),&odata2_ptr);CHKERRQ(ierr);
ierr = PetscBTCreate(Mbs,otable);CHKERRQ(ierr);
len_max = ois_max*(Mbs+1); /* max space storing all is[] for each receive */
len_est = 2*len_max; /* estimated space of storing is[] for all receiving messages */
ierr = PetscMalloc((len_est+1)*sizeof(PetscInt),&odata2);CHKERRQ(ierr);
nodata2 = 0; /* nodata2+1: num of PetscMalloc(,&odata2_ptr[]) called */
odata2_ptr[nodata2] = odata2;
len_unused = len_est; /* unused space in the array odata2_ptr[nodata2]-- needs to be >= len_max */
k = 0;
while (k < nrqr){
/* Receive messages */
ierr = MPI_Iprobe(MPI_ANY_SOURCE,tag1,comm,&flag,&r_status);CHKERRQ(ierr);
if (flag){
ierr = MPI_Get_count(&r_status,MPIU_INT,&len);CHKERRQ(ierr);
proc_id = r_status.MPI_SOURCE;
ierr = MPI_Irecv(odata1,len,MPIU_INT,proc_id,r_status.MPI_TAG,comm,&r_req);CHKERRQ(ierr);
ierr = MPI_Wait(&r_req,&r_status);CHKERRQ(ierr);
/* Process messages */
/* make sure there is enough unused space in odata2 array */
if (len_unused < len_max){ /* allocate more space for odata2 */
ierr = PetscMalloc((len_est+1)*sizeof(PetscInt),&odata2);CHKERRQ(ierr);
odata2_ptr[++nodata2] = odata2;
len_unused = len_est;
}
ierr = MatIncreaseOverlap_MPISBAIJ_Local(C,odata1,OTHER,odata2,&otable);CHKERRQ(ierr);
len = 1 + odata2[0];
for (i=0; i<odata2[0]; i++){
len += odata2[1 + i];
}
/* Send messages back */
ierr = MPI_Isend(odata2,len,MPIU_INT,proc_id,tag2,comm,s_waits2+k);CHKERRQ(ierr);
k++;
odata2 += len;
len_unused -= len;
len_s[proc_id] = len; /* num of messages sending back to [proc_id] by this proc */
}
}
ierr = PetscFree(odata1);CHKERRQ(ierr);
ierr = PetscBTDestroy(otable);CHKERRQ(ierr);
/* 3. Do local work on this processor's is[] */
/*-------------------------------------------*/
/* make sure there is enough unused space in odata2(=data) array */
len_max = is_max*(Mbs+1); /* max space storing all is[] for this processor */
if (len_unused < len_max){ /* allocate more space for odata2 */
ierr = PetscMalloc((len_est+1)*sizeof(PetscInt),&odata2);CHKERRQ(ierr);
odata2_ptr[++nodata2] = odata2;
len_unused = len_est;
}
data = odata2;
ierr = MatIncreaseOverlap_MPISBAIJ_Local(C,data1_start[rank],MINE,data,table);CHKERRQ(ierr);
ierr = PetscFree(data1_start);CHKERRQ(ierr);
/* 4. Receive work done on other processors, then merge */
/*------------------------------------------------------*/
/* get max number of messages that this processor expects to recv */
ierr = MPI_Allreduce(len_s,iwork,size,MPIU_INT,MPI_MAX,comm);CHKERRQ(ierr);
ierr = PetscMalloc((iwork[rank]+1)*sizeof(PetscInt),&data2);CHKERRQ(ierr);
ierr = PetscFree4(len_s,btable,iwork,Bowners);CHKERRQ(ierr);
k = 0;
while (k < nrqs){
/* Receive messages */
ierr = MPI_Iprobe(MPI_ANY_SOURCE,tag2,comm,&flag,&r_status);
if (flag){
ierr = MPI_Get_count(&r_status,MPIU_INT,&len);CHKERRQ(ierr);
proc_id = r_status.MPI_SOURCE;
ierr = MPI_Irecv(data2,len,MPIU_INT,proc_id,r_status.MPI_TAG,comm,&r_req);CHKERRQ(ierr);
ierr = MPI_Wait(&r_req,&r_status);CHKERRQ(ierr);
if (len > 1+is_max){ /* Add data2 into data */
data2_i = data2 + 1 + is_max;
for (i=0; i<is_max; i++){
table_i = table[i];
data_i = data + 1 + is_max + Mbs*i;
isz = data[1+i];
for (j=0; j<data2[1+i]; j++){
col = data2_i[j];
if (!PetscBTLookupSet(table_i,col)) {data_i[isz++] = col;}
}
data[1+i] = isz;
if (i < is_max - 1) data2_i += data2[1+i];
}
}
k++;
}
}
ierr = PetscFree(data2);CHKERRQ(ierr);
ierr = PetscFree2(table,t_p);CHKERRQ(ierr);
/* phase 1 sends are complete */
ierr = PetscMalloc(size*sizeof(MPI_Status),&s_status);CHKERRQ(ierr);
if (nrqs) {ierr = MPI_Waitall(nrqs,s_waits1,s_status);CHKERRQ(ierr);}
ierr = PetscFree(data1);CHKERRQ(ierr);
/* phase 2 sends are complete */
if (nrqr){ierr = MPI_Waitall(nrqr,s_waits2,s_status);CHKERRQ(ierr);}
ierr = PetscFree2(s_waits1,s_waits2);CHKERRQ(ierr);
ierr = PetscFree(s_status);CHKERRQ(ierr);
/* 5. Create new is[] */
/*--------------------*/
for (i=0; i<is_max; i++) {
data_i = data + 1 + is_max + Mbs*i;
ierr = ISCreateGeneral(PETSC_COMM_SELF,data[1+i],data_i,is+i);CHKERRQ(ierr);
}
for (k=0; k<=nodata2; k++){
ierr = PetscFree(odata2_ptr[k]);CHKERRQ(ierr);
}
ierr = PetscFree(odata2_ptr);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
static PetscErrorCode PCSetUp_Redistribute(PC pc)
{
PC_Redistribute *red = (PC_Redistribute*)pc->data;
PetscErrorCode ierr;
MPI_Comm comm;
PetscInt rstart,rend,i,nz,cnt,*rows,ncnt,dcnt,*drows;
PetscLayout map,nmap;
PetscMPIInt size,imdex,tag,n;
PetscInt *source = PETSC_NULL;
PetscMPIInt *nprocs = PETSC_NULL,nrecvs;
PetscInt j,nsends;
PetscInt *owner = PETSC_NULL,*starts = PETSC_NULL,count,slen;
PetscInt *rvalues,*svalues,recvtotal;
PetscMPIInt *onodes1,*olengths1;
MPI_Request *send_waits = PETSC_NULL,*recv_waits = PETSC_NULL;
MPI_Status recv_status,*send_status;
Vec tvec,diag;
Mat tmat;
const PetscScalar *d;
PetscFunctionBegin;
if (pc->setupcalled) {
ierr = KSPGetOperators(red->ksp,PETSC_NULL,&tmat,PETSC_NULL);CHKERRQ(ierr);
ierr = MatGetSubMatrix(pc->pmat,red->is,red->is,MAT_REUSE_MATRIX,&tmat);CHKERRQ(ierr);
ierr = KSPSetOperators(red->ksp,tmat,tmat,SAME_NONZERO_PATTERN);CHKERRQ(ierr);
} else {
PetscInt NN;
ierr = PetscObjectGetComm((PetscObject)pc,&comm);CHKERRQ(ierr);
ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)pc,&tag);CHKERRQ(ierr);
/* count non-diagonal rows on process */
ierr = MatGetOwnershipRange(pc->mat,&rstart,&rend);CHKERRQ(ierr);
cnt = 0;
for (i=rstart; i<rend; i++) {
ierr = MatGetRow(pc->mat,i,&nz,PETSC_NULL,PETSC_NULL);CHKERRQ(ierr);
if (nz > 1) cnt++;
ierr = MatRestoreRow(pc->mat,i,&nz,PETSC_NULL,PETSC_NULL);CHKERRQ(ierr);
}
ierr = PetscMalloc(cnt*sizeof(PetscInt),&rows);CHKERRQ(ierr);
ierr = PetscMalloc((rend - rstart - cnt)*sizeof(PetscInt),&drows);CHKERRQ(ierr);
/* list non-diagonal rows on process */
cnt = 0; dcnt = 0;
for (i=rstart; i<rend; i++) {
ierr = MatGetRow(pc->mat,i,&nz,PETSC_NULL,PETSC_NULL);CHKERRQ(ierr);
if (nz > 1) rows[cnt++] = i;
else drows[dcnt++] = i - rstart;
ierr = MatRestoreRow(pc->mat,i,&nz,PETSC_NULL,PETSC_NULL);CHKERRQ(ierr);
}
/* create PetscLayout for non-diagonal rows on each process */
ierr = PetscLayoutCreate(comm,&map);CHKERRQ(ierr);
ierr = PetscLayoutSetLocalSize(map,cnt);CHKERRQ(ierr);
ierr = PetscLayoutSetBlockSize(map,1);CHKERRQ(ierr);
ierr = PetscLayoutSetUp(map);CHKERRQ(ierr);
rstart = map->rstart;
rend = map->rend;
/* create PetscLayout for load-balanced non-diagonal rows on each process */
ierr = PetscLayoutCreate(comm,&nmap);CHKERRQ(ierr);
ierr = MPI_Allreduce(&cnt,&ncnt,1,MPIU_INT,MPI_SUM,comm);CHKERRQ(ierr);
ierr = PetscLayoutSetSize(nmap,ncnt);CHKERRQ(ierr);
ierr = PetscLayoutSetBlockSize(nmap,1);CHKERRQ(ierr);
ierr = PetscLayoutSetUp(nmap);CHKERRQ(ierr);
ierr = MatGetSize(pc->pmat,&NN,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscInfo2(pc,"Number of diagonal rows eliminated %d, percentage eliminated %g\n",NN-ncnt,((PetscReal)(NN-ncnt))/((PetscReal)(NN)));CHKERRQ(ierr);
/*
this code is taken from VecScatterCreate_PtoS()
Determines what rows need to be moved where to
load balance the non-diagonal rows
*/
/* count number of contributors to each processor */
ierr = PetscMalloc2(size,PetscMPIInt,&nprocs,cnt,PetscInt,&owner);CHKERRQ(ierr);
ierr = PetscMemzero(nprocs,size*sizeof(PetscMPIInt));CHKERRQ(ierr);
j = 0;
nsends = 0;
for (i=rstart; i<rend; i++) {
if (i < nmap->range[j]) j = 0;
for (; j<size; j++) {
if (i < nmap->range[j+1]) {
if (!nprocs[j]++) nsends++;
owner[i-rstart] = j;
break;
}
}
}
/* inform other processors of number of messages and max length*/
ierr = PetscGatherNumberOfMessages(comm,PETSC_NULL,nprocs,&nrecvs);CHKERRQ(ierr);
ierr = PetscGatherMessageLengths(comm,nsends,nrecvs,nprocs,&onodes1,&olengths1);CHKERRQ(ierr);
ierr = PetscSortMPIIntWithArray(nrecvs,onodes1,olengths1);CHKERRQ(ierr);
recvtotal = 0; for (i=0; i<nrecvs; i++) recvtotal += olengths1[i];
/* post receives: rvalues - rows I will own; count - nu */
ierr = PetscMalloc3(recvtotal,PetscInt,&rvalues,nrecvs,PetscInt,&source,nrecvs,MPI_Request,&recv_waits);CHKERRQ(ierr);
count = 0;
for (i=0; i<nrecvs; i++) {
ierr = MPI_Irecv((rvalues+count),olengths1[i],MPIU_INT,onodes1[i],tag,comm,recv_waits+i);CHKERRQ(ierr);
count += olengths1[i];
}
/* do sends:
1) starts[i] gives the starting index in svalues for stuff going to
the ith processor
*/
ierr = PetscMalloc3(cnt,PetscInt,&svalues,nsends,MPI_Request,&send_waits,size,PetscInt,&starts);CHKERRQ(ierr);
starts[0] = 0;
for (i=1; i<size; i++) { starts[i] = starts[i-1] + nprocs[i-1];}
for (i=0; i<cnt; i++) {
svalues[starts[owner[i]]++] = rows[i];
}
for (i=0; i<cnt; i++) rows[i] = rows[i] - rstart;
red->drows = drows;
red->dcnt = dcnt;
ierr = PetscFree(rows);CHKERRQ(ierr);
starts[0] = 0;
for (i=1; i<size; i++) { starts[i] = starts[i-1] + nprocs[i-1];}
count = 0;
for (i=0; i<size; i++) {
if (nprocs[i]) {
ierr = MPI_Isend(svalues+starts[i],nprocs[i],MPIU_INT,i,tag,comm,send_waits+count++);CHKERRQ(ierr);
}
}
/* wait on receives */
count = nrecvs;
slen = 0;
while (count) {
ierr = MPI_Waitany(nrecvs,recv_waits,&imdex,&recv_status);CHKERRQ(ierr);
/* unpack receives into our local space */
ierr = MPI_Get_count(&recv_status,MPIU_INT,&n);CHKERRQ(ierr);
slen += n;
count--;
}
if (slen != recvtotal) SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Total message lengths %D not expected %D",slen,recvtotal);
ierr = ISCreateGeneral(comm,slen,rvalues,PETSC_COPY_VALUES,&red->is);CHKERRQ(ierr);
/* free up all work space */
ierr = PetscFree(olengths1);CHKERRQ(ierr);
ierr = PetscFree(onodes1);CHKERRQ(ierr);
ierr = PetscFree3(rvalues,source,recv_waits);CHKERRQ(ierr);
ierr = PetscFree2(nprocs,owner);CHKERRQ(ierr);
if (nsends) { /* wait on sends */
ierr = PetscMalloc(nsends*sizeof(MPI_Status),&send_status);CHKERRQ(ierr);
ierr = MPI_Waitall(nsends,send_waits,send_status);CHKERRQ(ierr);
ierr = PetscFree(send_status);CHKERRQ(ierr);
}
ierr = PetscFree3(svalues,send_waits,starts);CHKERRQ(ierr);
ierr = PetscLayoutDestroy(&map);CHKERRQ(ierr);
ierr = PetscLayoutDestroy(&nmap);CHKERRQ(ierr);
ierr = VecCreateMPI(comm,slen,PETSC_DETERMINE,&red->b);CHKERRQ(ierr);
ierr = VecDuplicate(red->b,&red->x);CHKERRQ(ierr);
ierr = MatGetVecs(pc->pmat,&tvec,PETSC_NULL);CHKERRQ(ierr);
ierr = VecScatterCreate(tvec,red->is,red->b,PETSC_NULL,&red->scatter);CHKERRQ(ierr);
ierr = VecDestroy(&tvec);CHKERRQ(ierr);
ierr = MatGetSubMatrix(pc->pmat,red->is,red->is,MAT_INITIAL_MATRIX,&tmat);CHKERRQ(ierr);
ierr = KSPSetOperators(red->ksp,tmat,tmat,SAME_NONZERO_PATTERN);CHKERRQ(ierr);
ierr = MatDestroy(&tmat);CHKERRQ(ierr);
}
/* get diagonal portion of matrix */
ierr = PetscMalloc(red->dcnt*sizeof(PetscScalar),&red->diag);CHKERRQ(ierr);
ierr = MatGetVecs(pc->pmat,&diag,PETSC_NULL);CHKERRQ(ierr);
ierr = MatGetDiagonal(pc->pmat,diag);CHKERRQ(ierr);
ierr = VecGetArrayRead(diag,&d);CHKERRQ(ierr);
for (i=0; i<red->dcnt; i++) {
red->diag[i] = 1.0/d[red->drows[i]];
}
ierr = VecRestoreArrayRead(diag,&d);CHKERRQ(ierr);
ierr = VecDestroy(&diag);CHKERRQ(ierr);
ierr = KSPSetUp(red->ksp);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
/*@C
ISLocalToGlobalMappingGetInfo - Gets the neighbor information for each processor and
each index shared by more than one processor
Collective on ISLocalToGlobalMapping
Input Parameters:
. mapping - the mapping from local to global indexing
Output Parameter:
+ nproc - number of processors that are connected to this one
. proc - neighboring processors
. numproc - number of indices for each subdomain (processor)
- indices - indices of nodes (in local numbering) shared with neighbors (sorted by global numbering)
Level: advanced
Concepts: mapping^local to global
Fortran Usage:
$ ISLocalToGlobalMpngGetInfoSize(ISLocalToGlobalMapping,PetscInt nproc,PetscInt numprocmax,ierr) followed by
$ ISLocalToGlobalMappingGetInfo(ISLocalToGlobalMapping,PetscInt nproc, PetscInt procs[nproc],PetscInt numprocs[nproc],
PetscInt indices[nproc][numprocmax],ierr)
There is no ISLocalToGlobalMappingRestoreInfo() in Fortran. You must make sure that procs[], numprocs[] and
indices[][] are large enough arrays, either by allocating them dynamically or defining static ones large enough.
.seealso: ISLocalToGlobalMappingDestroy(), ISLocalToGlobalMappingCreateIS(), ISLocalToGlobalMappingCreate(),
ISLocalToGlobalMappingRestoreInfo()
@*/
PetscErrorCode PETSCVEC_DLLEXPORT ISLocalToGlobalMappingGetInfo(ISLocalToGlobalMapping mapping,PetscInt *nproc,PetscInt *procs[],PetscInt *numprocs[],PetscInt **indices[])
{
PetscErrorCode ierr;
PetscMPIInt size,rank,tag1,tag2,tag3,*len,*source,imdex;
PetscInt i,n = mapping->n,Ng,ng,max = 0,*lindices = mapping->indices;
PetscInt *nprocs,*owner,nsends,*sends,j,*starts,nmax,nrecvs,*recvs,proc;
PetscInt cnt,scale,*ownedsenders,*nownedsenders,rstart,nowned;
PetscInt node,nownedm,nt,*sends2,nsends2,*starts2,*lens2,*dest,nrecvs2,*starts3,*recvs2,k,*bprocs,*tmp;
PetscInt first_procs,first_numprocs,*first_indices;
MPI_Request *recv_waits,*send_waits;
MPI_Status recv_status,*send_status,*recv_statuses;
MPI_Comm comm = ((PetscObject)mapping)->comm;
PetscTruth debug = PETSC_FALSE;
PetscFunctionBegin;
PetscValidHeaderSpecific(mapping,IS_LTOGM_COOKIE,1);
ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);CHKERRQ(ierr);
if (size == 1) {
*nproc = 0;
*procs = PETSC_NULL;
ierr = PetscMalloc(sizeof(PetscInt),numprocs);CHKERRQ(ierr);
(*numprocs)[0] = 0;
ierr = PetscMalloc(sizeof(PetscInt*),indices);CHKERRQ(ierr);
(*indices)[0] = PETSC_NULL;
PetscFunctionReturn(0);
}
ierr = PetscOptionsGetTruth(PETSC_NULL,"-islocaltoglobalmappinggetinfo_debug",&debug,PETSC_NULL);CHKERRQ(ierr);
/*
Notes on ISLocalToGlobalMappingGetInfo
globally owned node - the nodes that have been assigned to this processor in global
numbering, just for this routine.
nontrivial globally owned node - node assigned to this processor that is on a subdomain
boundary (i.e. is has more than one local owner)
locally owned node - node that exists on this processors subdomain
nontrivial locally owned node - node that is not in the interior (i.e. has more than one
local subdomain
*/
ierr = PetscObjectGetNewTag((PetscObject)mapping,&tag1);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)mapping,&tag2);CHKERRQ(ierr);
ierr = PetscObjectGetNewTag((PetscObject)mapping,&tag3);CHKERRQ(ierr);
for (i=0; i<n; i++) {
if (lindices[i] > max) max = lindices[i];
}
ierr = MPI_Allreduce(&max,&Ng,1,MPIU_INT,MPI_MAX,comm);CHKERRQ(ierr);
Ng++;
ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);CHKERRQ(ierr);
scale = Ng/size + 1;
ng = scale; if (rank == size-1) ng = Ng - scale*(size-1); ng = PetscMax(1,ng);
rstart = scale*rank;
/* determine ownership ranges of global indices */
ierr = PetscMalloc(2*size*sizeof(PetscInt),&nprocs);CHKERRQ(ierr);
ierr = PetscMemzero(nprocs,2*size*sizeof(PetscInt));CHKERRQ(ierr);
/* determine owners of each local node */
ierr = PetscMalloc(n*sizeof(PetscInt),&owner);CHKERRQ(ierr);
for (i=0; i<n; i++) {
proc = lindices[i]/scale; /* processor that globally owns this index */
nprocs[2*proc+1] = 1; /* processor globally owns at least one of ours */
owner[i] = proc;
nprocs[2*proc]++; /* count of how many that processor globally owns of ours */
}
nsends = 0; for (i=0; i<size; i++) nsends += nprocs[2*i+1];
ierr = PetscInfo1(mapping,"Number of global owners for my local data %d\n",nsends);CHKERRQ(ierr);
/* inform other processors of number of messages and max length*/
ierr = PetscMaxSum(comm,nprocs,&nmax,&nrecvs);CHKERRQ(ierr);
ierr = PetscInfo1(mapping,"Number of local owners for my global data %d\n",nrecvs);CHKERRQ(ierr);
/* post receives for owned rows */
ierr = PetscMalloc((2*nrecvs+1)*(nmax+1)*sizeof(PetscInt),&recvs);CHKERRQ(ierr);
ierr = PetscMalloc((nrecvs+1)*sizeof(MPI_Request),&recv_waits);CHKERRQ(ierr);
for (i=0; i<nrecvs; i++) {
ierr = MPI_Irecv(recvs+2*nmax*i,2*nmax,MPIU_INT,MPI_ANY_SOURCE,tag1,comm,recv_waits+i);CHKERRQ(ierr);
}
/* pack messages containing lists of local nodes to owners */
ierr = PetscMalloc((2*n+1)*sizeof(PetscInt),&sends);CHKERRQ(ierr);
ierr = PetscMalloc((size+1)*sizeof(PetscInt),&starts);CHKERRQ(ierr);
starts[0] = 0;
for (i=1; i<size; i++) { starts[i] = starts[i-1] + 2*nprocs[2*i-2];}
for (i=0; i<n; i++) {
sends[starts[owner[i]]++] = lindices[i];
sends[starts[owner[i]]++] = i;
}
ierr = PetscFree(owner);CHKERRQ(ierr);
starts[0] = 0;
for (i=1; i<size; i++) { starts[i] = starts[i-1] + 2*nprocs[2*i-2];}
/* send the messages */
ierr = PetscMalloc((nsends+1)*sizeof(MPI_Request),&send_waits);CHKERRQ(ierr);
ierr = PetscMalloc((nsends+1)*sizeof(PetscInt),&dest);CHKERRQ(ierr);
cnt = 0;
for (i=0; i<size; i++) {
if (nprocs[2*i]) {
ierr = MPI_Isend(sends+starts[i],2*nprocs[2*i],MPIU_INT,i,tag1,comm,send_waits+cnt);CHKERRQ(ierr);
dest[cnt] = i;
cnt++;
}
}
ierr = PetscFree(starts);CHKERRQ(ierr);
/* wait on receives */
ierr = PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),&source);CHKERRQ(ierr);
ierr = PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),&len);CHKERRQ(ierr);
cnt = nrecvs;
ierr = PetscMalloc((ng+1)*sizeof(PetscInt),&nownedsenders);CHKERRQ(ierr);
ierr = PetscMemzero(nownedsenders,ng*sizeof(PetscInt));CHKERRQ(ierr);
while (cnt) {
ierr = MPI_Waitany(nrecvs,recv_waits,&imdex,&recv_status);CHKERRQ(ierr);
/* unpack receives into our local space */
ierr = MPI_Get_count(&recv_status,MPIU_INT,&len[imdex]);CHKERRQ(ierr);
source[imdex] = recv_status.MPI_SOURCE;
len[imdex] = len[imdex]/2;
/* count how many local owners for each of my global owned indices */
for (i=0; i<len[imdex]; i++) nownedsenders[recvs[2*imdex*nmax+2*i]-rstart]++;
cnt--;
}
ierr = PetscFree(recv_waits);CHKERRQ(ierr);
/* count how many globally owned indices are on an edge multiplied by how many processors own them. */
nowned = 0;
nownedm = 0;
for (i=0; i<ng; i++) {
if (nownedsenders[i] > 1) {nownedm += nownedsenders[i]; nowned++;}
}
/* create single array to contain rank of all local owners of each globally owned index */
ierr = PetscMalloc((nownedm+1)*sizeof(PetscInt),&ownedsenders);CHKERRQ(ierr);
ierr = PetscMalloc((ng+1)*sizeof(PetscInt),&starts);CHKERRQ(ierr);
starts[0] = 0;
for (i=1; i<ng; i++) {
if (nownedsenders[i-1] > 1) starts[i] = starts[i-1] + nownedsenders[i-1];
else starts[i] = starts[i-1];
}
/* for each nontrival globally owned node list all arriving processors */
for (i=0; i<nrecvs; i++) {
for (j=0; j<len[i]; j++) {
node = recvs[2*i*nmax+2*j]-rstart;
if (nownedsenders[node] > 1) {
ownedsenders[starts[node]++] = source[i];
}
}
}
if (debug) { /* ----------------------------------- */
starts[0] = 0;
for (i=1; i<ng; i++) {
if (nownedsenders[i-1] > 1) starts[i] = starts[i-1] + nownedsenders[i-1];
else starts[i] = starts[i-1];
}
for (i=0; i<ng; i++) {
if (nownedsenders[i] > 1) {
ierr = PetscSynchronizedPrintf(comm,"[%d] global node %d local owner processors: ",rank,i+rstart);CHKERRQ(ierr);
for (j=0; j<nownedsenders[i]; j++) {
ierr = PetscSynchronizedPrintf(comm,"%d ",ownedsenders[starts[i]+j]);CHKERRQ(ierr);
}
ierr = PetscSynchronizedPrintf(comm,"\n");CHKERRQ(ierr);
}
}
ierr = PetscSynchronizedFlush(comm);CHKERRQ(ierr);
}/* ----------------------------------- */
/* wait on original sends */
if (nsends) {
ierr = PetscMalloc(nsends*sizeof(MPI_Status),&send_status);CHKERRQ(ierr);
ierr = MPI_Waitall(nsends,send_waits,send_status);CHKERRQ(ierr);
ierr = PetscFree(send_status);CHKERRQ(ierr);
}
ierr = PetscFree(send_waits);CHKERRQ(ierr);
ierr = PetscFree(sends);CHKERRQ(ierr);
ierr = PetscFree(nprocs);CHKERRQ(ierr);
/* pack messages to send back to local owners */
starts[0] = 0;
for (i=1; i<ng; i++) {
if (nownedsenders[i-1] > 1) starts[i] = starts[i-1] + nownedsenders[i-1];
else starts[i] = starts[i-1];
}
nsends2 = nrecvs;
ierr = PetscMalloc((nsends2+1)*sizeof(PetscInt),&nprocs);CHKERRQ(ierr); /* length of each message */
for (i=0; i<nrecvs; i++) {
nprocs[i] = 1;
for (j=0; j<len[i]; j++) {
node = recvs[2*i*nmax+2*j]-rstart;
if (nownedsenders[node] > 1) {
nprocs[i] += 2 + nownedsenders[node];
}
}
}
nt = 0; for (i=0; i<nsends2; i++) nt += nprocs[i];
ierr = PetscMalloc((nt+1)*sizeof(PetscInt),&sends2);CHKERRQ(ierr);
ierr = PetscMalloc((nsends2+1)*sizeof(PetscInt),&starts2);CHKERRQ(ierr);
starts2[0] = 0; for (i=1; i<nsends2; i++) starts2[i] = starts2[i-1] + nprocs[i-1];
/*
Each message is 1 + nprocs[i] long, and consists of
(0) the number of nodes being sent back
(1) the local node number,
(2) the number of processors sharing it,
(3) the processors sharing it
*/
for (i=0; i<nsends2; i++) {
cnt = 1;
sends2[starts2[i]] = 0;
for (j=0; j<len[i]; j++) {
node = recvs[2*i*nmax+2*j]-rstart;
if (nownedsenders[node] > 1) {
sends2[starts2[i]]++;
sends2[starts2[i]+cnt++] = recvs[2*i*nmax+2*j+1];
sends2[starts2[i]+cnt++] = nownedsenders[node];
ierr = PetscMemcpy(&sends2[starts2[i]+cnt],&ownedsenders[starts[node]],nownedsenders[node]*sizeof(PetscInt));CHKERRQ(ierr);
cnt += nownedsenders[node];
}
}
}
/* receive the message lengths */
nrecvs2 = nsends;
ierr = PetscMalloc((nrecvs2+1)*sizeof(PetscInt),&lens2);CHKERRQ(ierr);
ierr = PetscMalloc((nrecvs2+1)*sizeof(PetscInt),&starts3);CHKERRQ(ierr);
ierr = PetscMalloc((nrecvs2+1)*sizeof(MPI_Request),&recv_waits);CHKERRQ(ierr);
for (i=0; i<nrecvs2; i++) {
ierr = MPI_Irecv(&lens2[i],1,MPIU_INT,dest[i],tag2,comm,recv_waits+i);CHKERRQ(ierr);
}
/* send the message lengths */
for (i=0; i<nsends2; i++) {
ierr = MPI_Send(&nprocs[i],1,MPIU_INT,source[i],tag2,comm);CHKERRQ(ierr);
}
/* wait on receives of lens */
if (nrecvs2) {
ierr = PetscMalloc(nrecvs2*sizeof(MPI_Status),&recv_statuses);CHKERRQ(ierr);
ierr = MPI_Waitall(nrecvs2,recv_waits,recv_statuses);CHKERRQ(ierr);
ierr = PetscFree(recv_statuses);CHKERRQ(ierr);
}
ierr = PetscFree(recv_waits);
starts3[0] = 0;
nt = 0;
for (i=0; i<nrecvs2-1; i++) {
starts3[i+1] = starts3[i] + lens2[i];
nt += lens2[i];
}
nt += lens2[nrecvs2-1];
ierr = PetscMalloc((nt+1)*sizeof(PetscInt),&recvs2);CHKERRQ(ierr);
ierr = PetscMalloc((nrecvs2+1)*sizeof(MPI_Request),&recv_waits);CHKERRQ(ierr);
for (i=0; i<nrecvs2; i++) {
ierr = MPI_Irecv(recvs2+starts3[i],lens2[i],MPIU_INT,dest[i],tag3,comm,recv_waits+i);CHKERRQ(ierr);
}
/* send the messages */
ierr = PetscMalloc((nsends2+1)*sizeof(MPI_Request),&send_waits);CHKERRQ(ierr);
for (i=0; i<nsends2; i++) {
ierr = MPI_Isend(sends2+starts2[i],nprocs[i],MPIU_INT,source[i],tag3,comm,send_waits+i);CHKERRQ(ierr);
}
/* wait on receives */
if (nrecvs2) {
ierr = PetscMalloc(nrecvs2*sizeof(MPI_Status),&recv_statuses);CHKERRQ(ierr);
ierr = MPI_Waitall(nrecvs2,recv_waits,recv_statuses);CHKERRQ(ierr);
ierr = PetscFree(recv_statuses);CHKERRQ(ierr);
}
ierr = PetscFree(recv_waits);CHKERRQ(ierr);
ierr = PetscFree(nprocs);CHKERRQ(ierr);
if (debug) { /* ----------------------------------- */
cnt = 0;
for (i=0; i<nrecvs2; i++) {
nt = recvs2[cnt++];
for (j=0; j<nt; j++) {
ierr = PetscSynchronizedPrintf(comm,"[%d] local node %d number of subdomains %d: ",rank,recvs2[cnt],recvs2[cnt+1]);CHKERRQ(ierr);
for (k=0; k<recvs2[cnt+1]; k++) {
ierr = PetscSynchronizedPrintf(comm,"%d ",recvs2[cnt+2+k]);CHKERRQ(ierr);
}
cnt += 2 + recvs2[cnt+1];
ierr = PetscSynchronizedPrintf(comm,"\n");CHKERRQ(ierr);
}
}
ierr = PetscSynchronizedFlush(comm);CHKERRQ(ierr);
} /* ----------------------------------- */
/* count number subdomains for each local node */
ierr = PetscMalloc(size*sizeof(PetscInt),&nprocs);CHKERRQ(ierr);
ierr = PetscMemzero(nprocs,size*sizeof(PetscInt));CHKERRQ(ierr);
cnt = 0;
for (i=0; i<nrecvs2; i++) {
nt = recvs2[cnt++];
for (j=0; j<nt; j++) {
for (k=0; k<recvs2[cnt+1]; k++) {
nprocs[recvs2[cnt+2+k]]++;
}
cnt += 2 + recvs2[cnt+1];
}
}
nt = 0; for (i=0; i<size; i++) nt += (nprocs[i] > 0);
*nproc = nt;
ierr = PetscMalloc((nt+1)*sizeof(PetscInt),procs);CHKERRQ(ierr);
ierr = PetscMalloc((nt+1)*sizeof(PetscInt),numprocs);CHKERRQ(ierr);
ierr = PetscMalloc((nt+1)*sizeof(PetscInt*),indices);CHKERRQ(ierr);
ierr = PetscMalloc(size*sizeof(PetscInt),&bprocs);CHKERRQ(ierr);
cnt = 0;
for (i=0; i<size; i++) {
if (nprocs[i] > 0) {
bprocs[i] = cnt;
(*procs)[cnt] = i;
(*numprocs)[cnt] = nprocs[i];
ierr = PetscMalloc(nprocs[i]*sizeof(PetscInt),&(*indices)[cnt]);CHKERRQ(ierr);
cnt++;
}
}
/* make the list of subdomains for each nontrivial local node */
ierr = PetscMemzero(*numprocs,nt*sizeof(PetscInt));CHKERRQ(ierr);
cnt = 0;
for (i=0; i<nrecvs2; i++) {
nt = recvs2[cnt++];
for (j=0; j<nt; j++) {
for (k=0; k<recvs2[cnt+1]; k++) {
(*indices)[bprocs[recvs2[cnt+2+k]]][(*numprocs)[bprocs[recvs2[cnt+2+k]]]++] = recvs2[cnt];
}
cnt += 2 + recvs2[cnt+1];
}
}
ierr = PetscFree(bprocs);CHKERRQ(ierr);
ierr = PetscFree(recvs2);CHKERRQ(ierr);
/* sort the node indexing by their global numbers */
nt = *nproc;
for (i=0; i<nt; i++) {
ierr = PetscMalloc(((*numprocs)[i])*sizeof(PetscInt),&tmp);CHKERRQ(ierr);
for (j=0; j<(*numprocs)[i]; j++) {
tmp[j] = lindices[(*indices)[i][j]];
}
ierr = PetscSortIntWithArray((*numprocs)[i],tmp,(*indices)[i]);CHKERRQ(ierr);
ierr = PetscFree(tmp);CHKERRQ(ierr);
}
if (debug) { /* ----------------------------------- */
nt = *nproc;
for (i=0; i<nt; i++) {
ierr = PetscSynchronizedPrintf(comm,"[%d] subdomain %d number of indices %d: ",rank,(*procs)[i],(*numprocs)[i]);CHKERRQ(ierr);
for (j=0; j<(*numprocs)[i]; j++) {
ierr = PetscSynchronizedPrintf(comm,"%d ",(*indices)[i][j]);CHKERRQ(ierr);
}
ierr = PetscSynchronizedPrintf(comm,"\n");CHKERRQ(ierr);
}
ierr = PetscSynchronizedFlush(comm);CHKERRQ(ierr);
} /* ----------------------------------- */
/* wait on sends */
if (nsends2) {
ierr = PetscMalloc(nsends2*sizeof(MPI_Status),&send_status);CHKERRQ(ierr);
ierr = MPI_Waitall(nsends2,send_waits,send_status);CHKERRQ(ierr);
ierr = PetscFree(send_status);CHKERRQ(ierr);
}
ierr = PetscFree(starts3);CHKERRQ(ierr);
ierr = PetscFree(dest);CHKERRQ(ierr);
ierr = PetscFree(send_waits);CHKERRQ(ierr);
ierr = PetscFree(nownedsenders);CHKERRQ(ierr);
ierr = PetscFree(ownedsenders);CHKERRQ(ierr);
ierr = PetscFree(starts);CHKERRQ(ierr);
ierr = PetscFree(starts2);CHKERRQ(ierr);
ierr = PetscFree(lens2);CHKERRQ(ierr);
ierr = PetscFree(source);CHKERRQ(ierr);
ierr = PetscFree(len);CHKERRQ(ierr);
ierr = PetscFree(recvs);CHKERRQ(ierr);
ierr = PetscFree(nprocs);CHKERRQ(ierr);
ierr = PetscFree(sends2);CHKERRQ(ierr);
/* put the information about myself as the first entry in the list */
first_procs = (*procs)[0];
first_numprocs = (*numprocs)[0];
first_indices = (*indices)[0];
for (i=0; i<*nproc; i++) {
if ((*procs)[i] == rank) {
(*procs)[0] = (*procs)[i];
(*numprocs)[0] = (*numprocs)[i];
(*indices)[0] = (*indices)[i];
(*procs)[i] = first_procs;
(*numprocs)[i] = first_numprocs;
(*indices)[i] = first_indices;
break;
}
}
PetscFunctionReturn(0);
}
PetscErrorCode MatGetSubMatrices_MPIDense_Local(Mat C,PetscInt ismax,const IS isrow[],const IS iscol[],MatReuse scall,Mat *submats)
{
Mat_MPIDense *c = (Mat_MPIDense*)C->data;
Mat A = c->A;
Mat_SeqDense *a = (Mat_SeqDense*)A->data,*mat;
PetscErrorCode ierr;
PetscMPIInt rank,size,tag0,tag1,idex,end,i;
PetscInt N = C->cmap->N,rstart = C->rmap->rstart,count;
const PetscInt **irow,**icol,*irow_i;
PetscInt *nrow,*ncol,*w1,*w3,*w4,*rtable,start;
PetscInt **sbuf1,m,j,k,l,ct1,**rbuf1,row,proc;
PetscInt nrqs,msz,**ptr,*ctr,*pa,*tmp,bsz,nrqr;
PetscInt is_no,jmax,**rmap,*rmap_i;
PetscInt ctr_j,*sbuf1_j,*rbuf1_i;
MPI_Request *s_waits1,*r_waits1,*s_waits2,*r_waits2;
MPI_Status *r_status1,*r_status2,*s_status1,*s_status2;
MPI_Comm comm;
PetscScalar **rbuf2,**sbuf2;
PetscBool sorted;
PetscFunctionBegin;
comm = ((PetscObject)C)->comm;
tag0 = ((PetscObject)C)->tag;
size = c->size;
rank = c->rank;
m = C->rmap->N;
/* Get some new tags to keep the communication clean */
ierr = PetscObjectGetNewTag((PetscObject)C,&tag1);CHKERRQ(ierr);
/* Check if the col indices are sorted */
for (i=0; i<ismax; i++) {
ierr = ISSorted(isrow[i],&sorted);CHKERRQ(ierr);
if (!sorted) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONGSTATE,"ISrow is not sorted");
ierr = ISSorted(iscol[i],&sorted);CHKERRQ(ierr);
if (!sorted) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONGSTATE,"IScol is not sorted");
}
ierr = PetscMalloc5(ismax,const PetscInt*,&irow,ismax,const PetscInt*,&icol,ismax,PetscInt,&nrow,ismax,PetscInt,&ncol,m,PetscInt,&rtable);CHKERRQ(ierr);
for (i=0; i<ismax; i++) {
ierr = ISGetIndices(isrow[i],&irow[i]);CHKERRQ(ierr);
ierr = ISGetIndices(iscol[i],&icol[i]);CHKERRQ(ierr);
ierr = ISGetLocalSize(isrow[i],&nrow[i]);CHKERRQ(ierr);
ierr = ISGetLocalSize(iscol[i],&ncol[i]);CHKERRQ(ierr);
}
/* Create hash table for the mapping :row -> proc*/
for (i=0,j=0; i<size; i++) {
jmax = C->rmap->range[i+1];
for (; j<jmax; j++) {
rtable[j] = i;
}
}
/* evaluate communication - mesg to who,length of mesg, and buffer space
required. Based on this, buffers are allocated, and data copied into them*/
ierr = PetscMalloc3(2*size,PetscInt,&w1,size,PetscInt,&w3,size,PetscInt,&w4);CHKERRQ(ierr);
ierr = PetscMemzero(w1,size*2*sizeof(PetscInt));CHKERRQ(ierr); /* initialize work vector*/
ierr = PetscMemzero(w3,size*sizeof(PetscInt));CHKERRQ(ierr); /* initialize work vector*/
for (i=0; i<ismax; i++) {
ierr = PetscMemzero(w4,size*sizeof(PetscInt));CHKERRQ(ierr); /* initialize work vector*/
jmax = nrow[i];
irow_i = irow[i];
for (j=0; j<jmax; j++) {
row = irow_i[j];
proc = rtable[row];
w4[proc]++;
}
for (j=0; j<size; j++) {
if (w4[j]) { w1[2*j] += w4[j]; w3[j]++;}
}
}
nrqs = 0; /* no of outgoing messages */
msz = 0; /* total mesg length (for all procs) */
w1[2*rank] = 0; /* no mesg sent to self */
w3[rank] = 0;
for (i=0; i<size; i++) {
if (w1[2*i]) { w1[2*i+1] = 1; nrqs++;} /* there exists a message to proc i */
}
ierr = PetscMalloc((nrqs+1)*sizeof(PetscInt),&pa);CHKERRQ(ierr); /*(proc -array)*/
for (i=0,j=0; i<size; i++) {
if (w1[2*i]) { pa[j] = i; j++; }
}
/* Each message would have a header = 1 + 2*(no of IS) + data */
for (i=0; i<nrqs; i++) {
j = pa[i];
w1[2*j] += w1[2*j+1] + 2* w3[j];
msz += w1[2*j];
}
/* Do a global reduction to determine how many messages to expect*/
ierr = PetscMaxSum(comm,w1,&bsz,&nrqr);CHKERRQ(ierr);
/* Allocate memory for recv buffers . Make sure rbuf1[0] exists by adding 1 to the buffer length */
ierr = PetscMalloc((nrqr+1)*sizeof(PetscInt*),&rbuf1);CHKERRQ(ierr);
ierr = PetscMalloc(nrqr*bsz*sizeof(PetscInt),&rbuf1[0]);CHKERRQ(ierr);
for (i=1; i<nrqr; ++i) rbuf1[i] = rbuf1[i-1] + bsz;
/* Post the receives */
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Request),&r_waits1);CHKERRQ(ierr);
for (i=0; i<nrqr; ++i) {
ierr = MPI_Irecv(rbuf1[i],bsz,MPIU_INT,MPI_ANY_SOURCE,tag0,comm,r_waits1+i);CHKERRQ(ierr);
}
/* Allocate Memory for outgoing messages */
ierr = PetscMalloc4(size,PetscInt*,&sbuf1,size,PetscInt*,&ptr,2*msz,PetscInt,&tmp,size,PetscInt,&ctr);CHKERRQ(ierr);
ierr = PetscMemzero(sbuf1,size*sizeof(PetscInt*));CHKERRQ(ierr);
ierr = PetscMemzero(ptr,size*sizeof(PetscInt*));CHKERRQ(ierr);
{
PetscInt *iptr = tmp,ict = 0;
for (i=0; i<nrqs; i++) {
j = pa[i];
iptr += ict;
sbuf1[j] = iptr;
ict = w1[2*j];
}
}
/* Form the outgoing messages */
/* Initialize the header space */
for (i=0; i<nrqs; i++) {
j = pa[i];
sbuf1[j][0] = 0;
ierr = PetscMemzero(sbuf1[j]+1,2*w3[j]*sizeof(PetscInt));CHKERRQ(ierr);
ptr[j] = sbuf1[j] + 2*w3[j] + 1;
}
/* Parse the isrow and copy data into outbuf */
for (i=0; i<ismax; i++) {
ierr = PetscMemzero(ctr,size*sizeof(PetscInt));CHKERRQ(ierr);
irow_i = irow[i];
jmax = nrow[i];
for (j=0; j<jmax; j++) { /* parse the indices of each IS */
row = irow_i[j];
proc = rtable[row];
if (proc != rank) { /* copy to the outgoing buf*/
ctr[proc]++;
*ptr[proc] = row;
ptr[proc]++;
}
}
/* Update the headers for the current IS */
for (j=0; j<size; j++) { /* Can Optimise this loop too */
if ((ctr_j = ctr[j])) {
sbuf1_j = sbuf1[j];
k = ++sbuf1_j[0];
sbuf1_j[2*k] = ctr_j;
sbuf1_j[2*k-1] = i;
}
}
}
/* Now post the sends */
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Request),&s_waits1);CHKERRQ(ierr);
for (i=0; i<nrqs; ++i) {
j = pa[i];
ierr = MPI_Isend(sbuf1[j],w1[2*j],MPIU_INT,j,tag0,comm,s_waits1+i);CHKERRQ(ierr);
}
/* Post recieves to capture the row_data from other procs */
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Request),&r_waits2);CHKERRQ(ierr);
ierr = PetscMalloc((nrqs+1)*sizeof(PetscScalar*),&rbuf2);CHKERRQ(ierr);
for (i=0; i<nrqs; i++) {
j = pa[i];
count = (w1[2*j] - (2*sbuf1[j][0] + 1))*N;
ierr = PetscMalloc((count+1)*sizeof(PetscScalar),&rbuf2[i]);CHKERRQ(ierr);
ierr = MPI_Irecv(rbuf2[i],count,MPIU_SCALAR,j,tag1,comm,r_waits2+i);CHKERRQ(ierr);
}
/* Receive messages(row_nos) and then, pack and send off the rowvalues
to the correct processors */
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Request),&s_waits2);CHKERRQ(ierr);
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Status),&r_status1);CHKERRQ(ierr);
ierr = PetscMalloc((nrqr+1)*sizeof(PetscScalar*),&sbuf2);CHKERRQ(ierr);
{
PetscScalar *sbuf2_i,*v_start;
PetscInt s_proc;
for (i=0; i<nrqr; ++i) {
ierr = MPI_Waitany(nrqr,r_waits1,&idex,r_status1+i);CHKERRQ(ierr);
s_proc = r_status1[i].MPI_SOURCE; /* send processor */
rbuf1_i = rbuf1[idex]; /* Actual message from s_proc */
/* no of rows = end - start; since start is array idex[], 0idex, whel end
is length of the buffer - which is 1idex */
start = 2*rbuf1_i[0] + 1;
ierr = MPI_Get_count(r_status1+i,MPIU_INT,&end);CHKERRQ(ierr);
/* allocate memory sufficinet to hold all the row values */
ierr = PetscMalloc((end-start)*N*sizeof(PetscScalar),&sbuf2[idex]);CHKERRQ(ierr);
sbuf2_i = sbuf2[idex];
/* Now pack the data */
for (j=start; j<end; j++) {
row = rbuf1_i[j] - rstart;
v_start = a->v + row;
for (k=0; k<N; k++) {
sbuf2_i[0] = v_start[0];
sbuf2_i++; v_start += C->rmap->n;
}
}
/* Now send off the data */
ierr = MPI_Isend(sbuf2[idex],(end-start)*N,MPIU_SCALAR,s_proc,tag1,comm,s_waits2+i);CHKERRQ(ierr);
}
}
/* End Send-Recv of IS + row_numbers */
ierr = PetscFree(r_status1);CHKERRQ(ierr);
ierr = PetscFree(r_waits1);CHKERRQ(ierr);
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Status),&s_status1);CHKERRQ(ierr);
if (nrqs) {ierr = MPI_Waitall(nrqs,s_waits1,s_status1);CHKERRQ(ierr);}
ierr = PetscFree(s_status1);CHKERRQ(ierr);
ierr = PetscFree(s_waits1);CHKERRQ(ierr);
/* Create the submatrices */
if (scall == MAT_REUSE_MATRIX) {
for (i=0; i<ismax; i++) {
mat = (Mat_SeqDense *)(submats[i]->data);
if ((submats[i]->rmap->n != nrow[i]) || (submats[i]->cmap->n != ncol[i])) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_SIZ,"Cannot reuse matrix. wrong size");
ierr = PetscMemzero(mat->v,submats[i]->rmap->n*submats[i]->cmap->n*sizeof(PetscScalar));CHKERRQ(ierr);
submats[i]->factortype = C->factortype;
}
} else {
for (i=0; i<ismax; i++) {
ierr = MatCreate(PETSC_COMM_SELF,submats+i);CHKERRQ(ierr);
ierr = MatSetSizes(submats[i],nrow[i],ncol[i],nrow[i],ncol[i]);CHKERRQ(ierr);
ierr = MatSetType(submats[i],((PetscObject)A)->type_name);CHKERRQ(ierr);
ierr = MatSeqDenseSetPreallocation(submats[i],PETSC_NULL);CHKERRQ(ierr);
}
}
/* Assemble the matrices */
{
PetscInt col;
PetscScalar *imat_v,*mat_v,*imat_vi,*mat_vi;
for (i=0; i<ismax; i++) {
mat = (Mat_SeqDense*)submats[i]->data;
mat_v = a->v;
imat_v = mat->v;
irow_i = irow[i];
m = nrow[i];
for (j=0; j<m; j++) {
row = irow_i[j] ;
proc = rtable[row];
if (proc == rank) {
row = row - rstart;
mat_vi = mat_v + row;
imat_vi = imat_v + j;
for (k=0; k<ncol[i]; k++) {
col = icol[i][k];
imat_vi[k*m] = mat_vi[col*C->rmap->n];
}
}
}
}
}
/* Create row map-> This maps c->row to submat->row for each submat*/
/* this is a very expensive operation wrt memory usage */
ierr = PetscMalloc(ismax*sizeof(PetscInt*),&rmap);CHKERRQ(ierr);
ierr = PetscMalloc(ismax*C->rmap->N*sizeof(PetscInt),&rmap[0]);CHKERRQ(ierr);
ierr = PetscMemzero(rmap[0],ismax*C->rmap->N*sizeof(PetscInt));CHKERRQ(ierr);
for (i=1; i<ismax; i++) { rmap[i] = rmap[i-1] + C->rmap->N;}
for (i=0; i<ismax; i++) {
rmap_i = rmap[i];
irow_i = irow[i];
jmax = nrow[i];
for (j=0; j<jmax; j++) {
rmap_i[irow_i[j]] = j;
}
}
/* Now Receive the row_values and assemble the rest of the matrix */
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Status),&r_status2);CHKERRQ(ierr);
{
PetscInt is_max,tmp1,col,*sbuf1_i,is_sz;
PetscScalar *rbuf2_i,*imat_v,*imat_vi;
for (tmp1=0; tmp1<nrqs; tmp1++) { /* For each message */
ierr = MPI_Waitany(nrqs,r_waits2,&i,r_status2+tmp1);CHKERRQ(ierr);
/* Now dig out the corresponding sbuf1, which contains the IS data_structure */
sbuf1_i = sbuf1[pa[i]];
is_max = sbuf1_i[0];
ct1 = 2*is_max+1;
rbuf2_i = rbuf2[i];
for (j=1; j<=is_max; j++) { /* For each IS belonging to the message */
is_no = sbuf1_i[2*j-1];
is_sz = sbuf1_i[2*j];
mat = (Mat_SeqDense*)submats[is_no]->data;
imat_v = mat->v;
rmap_i = rmap[is_no];
m = nrow[is_no];
for (k=0; k<is_sz; k++,rbuf2_i+=N) { /* For each row */
row = sbuf1_i[ct1]; ct1++;
row = rmap_i[row];
imat_vi = imat_v + row;
for (l=0; l<ncol[is_no]; l++) { /* For each col */
col = icol[is_no][l];
imat_vi[l*m] = rbuf2_i[col];
}
}
}
}
}
/* End Send-Recv of row_values */
ierr = PetscFree(r_status2);CHKERRQ(ierr);
ierr = PetscFree(r_waits2);CHKERRQ(ierr);
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Status),&s_status2);CHKERRQ(ierr);
if (nrqr) {ierr = MPI_Waitall(nrqr,s_waits2,s_status2);CHKERRQ(ierr);}
ierr = PetscFree(s_status2);CHKERRQ(ierr);
ierr = PetscFree(s_waits2);CHKERRQ(ierr);
/* Restore the indices */
for (i=0; i<ismax; i++) {
ierr = ISRestoreIndices(isrow[i],irow+i);CHKERRQ(ierr);
ierr = ISRestoreIndices(iscol[i],icol+i);CHKERRQ(ierr);
}
/* Destroy allocated memory */
ierr = PetscFree5(irow,icol,nrow,ncol,rtable);CHKERRQ(ierr);
ierr = PetscFree3(w1,w3,w4);CHKERRQ(ierr);
ierr = PetscFree(pa);CHKERRQ(ierr);
for (i=0; i<nrqs; ++i) {
ierr = PetscFree(rbuf2[i]);CHKERRQ(ierr);
}
ierr = PetscFree(rbuf2);CHKERRQ(ierr);
ierr = PetscFree4(sbuf1,ptr,tmp,ctr);CHKERRQ(ierr);
ierr = PetscFree(rbuf1[0]);CHKERRQ(ierr);
ierr = PetscFree(rbuf1);CHKERRQ(ierr);
for (i=0; i<nrqr; ++i) {
ierr = PetscFree(sbuf2[i]);CHKERRQ(ierr);
}
ierr = PetscFree(sbuf2);CHKERRQ(ierr);
ierr = PetscFree(rmap[0]);CHKERRQ(ierr);
ierr = PetscFree(rmap);CHKERRQ(ierr);
for (i=0; i<ismax; i++) {
ierr = MatAssemblyBegin(submats[i],MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(submats[i],MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
PETSC_EXTERN PetscErrorCode KSPCreate_AGMRES(KSP ksp)
{
KSP_AGMRES *agmres;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = PetscNewLog(ksp,&agmres);CHKERRQ(ierr);
ksp->data = (void*)agmres;
ierr = KSPSetSupportedNorm(ksp,KSP_NORM_PRECONDITIONED,PC_LEFT,3);CHKERRQ(ierr);
ierr = KSPSetSupportedNorm(ksp,KSP_NORM_UNPRECONDITIONED,PC_RIGHT,2);CHKERRQ(ierr);
ksp->ops->buildsolution = KSPBuildSolution_AGMRES;
ksp->ops->setup = KSPSetUp_AGMRES;
ksp->ops->solve = KSPSolve_AGMRES;
ksp->ops->destroy = KSPDestroy_AGMRES;
ksp->ops->view = KSPView_AGMRES;
ksp->ops->setfromoptions = KSPSetFromOptions_AGMRES;
ksp->guess_zero = PETSC_TRUE;
ksp->ops->computeextremesingularvalues = KSPComputeExtremeSingularValues_GMRES;
ksp->ops->computeeigenvalues = KSPComputeEigenvalues_GMRES;
ierr = PetscObjectComposeFunction((PetscObject) ksp,"KSPGMRESSetPreAllocateVectors_C",KSPGMRESSetPreAllocateVectors_GMRES);CHKERRQ(ierr);
ierr = PetscObjectComposeFunction((PetscObject) ksp,"KSPGMRESSetOrthogonalization_C",KSPGMRESSetOrthogonalization_GMRES);CHKERRQ(ierr);
ierr = PetscObjectComposeFunction((PetscObject) ksp,"KSPGMRESSetRestart_C",KSPGMRESSetRestart_GMRES);CHKERRQ(ierr);
ierr = PetscObjectComposeFunction((PetscObject) ksp,"KSPGMRESSetHapTol_C",KSPGMRESSetHapTol_GMRES);CHKERRQ(ierr);
ierr = PetscObjectComposeFunction((PetscObject) ksp,"KSPGMRESSetCGSRefinementType_C",KSPGMRESSetCGSRefinementType_GMRES);CHKERRQ(ierr);
/* -- New functions defined in DGMRES -- */
ierr=PetscObjectComposeFunction((PetscObject) ksp, "KSPDGMRESSetEigen_C",KSPDGMRESSetEigen_DGMRES);CHKERRQ(ierr);
ierr=PetscObjectComposeFunction((PetscObject) ksp, "KSPDGMRESComputeSchurForm_C",KSPDGMRESComputeSchurForm_DGMRES);CHKERRQ(ierr);
ierr=PetscObjectComposeFunction((PetscObject) ksp, "KSPDGMRESComputeDeflationData_C",KSPDGMRESComputeDeflationData_DGMRES);CHKERRQ(ierr);
ierr=PetscObjectComposeFunction((PetscObject) ksp, "KSPDGMRESApplyDeflation_C",KSPDGMRESApplyDeflation_DGMRES);CHKERRQ(ierr);
ierr = PetscLogEventRegister("AGMRESComputeDefl", KSP_CLASSID, &KSP_AGMRESComputeDeflationData);CHKERRQ(ierr);
ierr = PetscLogEventRegister("AGMRESBuildBasis", KSP_CLASSID, &KSP_AGMRESBuildBasis);CHKERRQ(ierr);
ierr = PetscLogEventRegister("AGMRESCompShifts", KSP_CLASSID, &KSP_AGMRESComputeShifts);CHKERRQ(ierr);
ierr = PetscLogEventRegister("AGMRESOrthog", KSP_CLASSID, &KSP_AGMRESRoddec);CHKERRQ(ierr);
agmres->haptol = 1.0e-30;
agmres->q_preallocate = 0;
agmres->delta_allocate = AGMRES_DELTA_DIRECTIONS;
agmres->orthog = KSPGMRESClassicalGramSchmidtOrthogonalization;
agmres->nrs = 0;
agmres->sol_temp = 0;
agmres->max_k = AGMRES_DEFAULT_MAXK;
agmres->Rsvd = 0;
agmres->cgstype = KSP_GMRES_CGS_REFINE_NEVER;
agmres->orthogwork = 0;
/* Default values for the deflation */
agmres->r = 0;
agmres->neig = 0;
agmres->max_neig = 0;
agmres->lambdaN = 0.0;
agmres->smv = SMV;
agmres->bgv = 1;
agmres->force = PETSC_FALSE;
agmres->matvecs = 0;
agmres->improve = PETSC_FALSE;
agmres->HasShifts = PETSC_FALSE;
agmres->r = 0;
agmres->HasSchur = PETSC_FALSE;
agmres->DeflPrecond = PETSC_FALSE;
ierr = PetscObjectGetNewTag((PetscObject)ksp,&agmres->tag);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
EXTERN_C_END
/* -------------------------------------------------------------------------- */
/*
PCNNCreateCoarseMatrix -
*/
#undef __FUNCT__
#define __FUNCT__ "PCNNCreateCoarseMatrix"
PetscErrorCode PCNNCreateCoarseMatrix (PC pc)
{
MPI_Request *send_request, *recv_request;
PetscErrorCode ierr;
PetscInt i, j, k;
PetscScalar* mat; /* Sub-matrix with this subdomain's contribution to the coarse matrix */
PetscScalar** DZ_OUT; /* proc[k].DZ_OUT[i][] = bit of vector to be sent from processor k to processor i */
/* aliasing some names */
PC_IS* pcis = (PC_IS*)(pc->data);
PC_NN* pcnn = (PC_NN*)pc->data;
PetscInt n_neigh = pcis->n_neigh;
PetscInt* neigh = pcis->neigh;
PetscInt* n_shared = pcis->n_shared;
PetscInt** shared = pcis->shared;
PetscScalar** DZ_IN; /* Must be initialized after memory allocation. */
PetscFunctionBegin;
/* Allocate memory for mat (the +1 is to handle the case n_neigh equal to zero) */
ierr = PetscMalloc((n_neigh*n_neigh+1)*sizeof(PetscScalar),&mat);CHKERRQ(ierr);
/* Allocate memory for DZ */
/* Notice that DZ_OUT[0] is allocated some space that is never used. */
/* This is just in order to DZ_OUT and DZ_IN to have exactly the same form. */
{
PetscInt size_of_Z = 0;
ierr = PetscMalloc ((n_neigh+1)*sizeof(PetscScalar*),&pcnn->DZ_IN);CHKERRQ(ierr);
DZ_IN = pcnn->DZ_IN;
ierr = PetscMalloc ((n_neigh+1)*sizeof(PetscScalar*),&DZ_OUT);CHKERRQ(ierr);
for (i=0; i<n_neigh; i++) {
size_of_Z += n_shared[i];
}
ierr = PetscMalloc ((size_of_Z+1)*sizeof(PetscScalar),&DZ_IN[0]);CHKERRQ(ierr);
ierr = PetscMalloc ((size_of_Z+1)*sizeof(PetscScalar),&DZ_OUT[0]);CHKERRQ(ierr);
}
for (i=1; i<n_neigh; i++) {
DZ_IN[i] = DZ_IN [i-1] + n_shared[i-1];
DZ_OUT[i] = DZ_OUT[i-1] + n_shared[i-1];
}
/* Set the values of DZ_OUT, in order to send this info to the neighbours */
/* First, set the auxiliary array pcis->work_N. */
ierr = PCISScatterArrayNToVecB(pcis->work_N,pcis->D,INSERT_VALUES,SCATTER_REVERSE,pc);CHKERRQ(ierr);
for (i=1; i<n_neigh; i++){
for (j=0; j<n_shared[i]; j++) {
DZ_OUT[i][j] = pcis->work_N[shared[i][j]];
}
}
/* Non-blocking send/receive the common-interface chunks of scaled nullspaces */
/* Notice that send_request[] and recv_request[] could have one less element. */
/* We make them longer to have request[i] corresponding to neigh[i]. */
{
PetscMPIInt tag;
ierr = PetscObjectGetNewTag((PetscObject)pc,&tag);CHKERRQ(ierr);
ierr = PetscMalloc((2*(n_neigh)+1)*sizeof(MPI_Request),&send_request);CHKERRQ(ierr);
recv_request = send_request + (n_neigh);
for (i=1; i<n_neigh; i++) {
ierr = MPI_Isend((void*)(DZ_OUT[i]),n_shared[i],MPIU_SCALAR,neigh[i],tag,((PetscObject)pc)->comm,&(send_request[i]));CHKERRQ(ierr);
ierr = MPI_Irecv((void*)(DZ_IN [i]),n_shared[i],MPIU_SCALAR,neigh[i],tag,((PetscObject)pc)->comm,&(recv_request[i]));CHKERRQ(ierr);
}
}
/* Set DZ_IN[0][] (recall that neigh[0]==rank, always) */
for(j=0; j<n_shared[0]; j++) {
DZ_IN[0][j] = pcis->work_N[shared[0][j]];
}
/* Start computing with local D*Z while communication goes on. */
/* Apply Schur complement. The result is "stored" in vec (more */
/* precisely, vec points to the result, stored in pc_nn->vec1_B) */
/* and also scattered to pcnn->work_N. */
ierr = PCNNApplySchurToChunk(pc,n_shared[0],shared[0],DZ_IN[0],pcis->work_N,pcis->vec1_B,
pcis->vec2_B,pcis->vec1_D,pcis->vec2_D);CHKERRQ(ierr);
/* Compute the first column, while completing the receiving. */
for (i=0; i<n_neigh; i++) {
MPI_Status stat;
PetscMPIInt ind=0;
if (i>0) { ierr = MPI_Waitany(n_neigh-1,recv_request+1,&ind,&stat);CHKERRQ(ierr); ind++;}
mat[ind*n_neigh+0] = 0.0;
for (k=0; k<n_shared[ind]; k++) {
mat[ind*n_neigh+0] += DZ_IN[ind][k] * pcis->work_N[shared[ind][k]];
}
}
/* Compute the remaining of the columns */
for (j=1; j<n_neigh; j++) {
ierr = PCNNApplySchurToChunk(pc,n_shared[j],shared[j],DZ_IN[j],pcis->work_N,pcis->vec1_B,
pcis->vec2_B,pcis->vec1_D,pcis->vec2_D);CHKERRQ(ierr);
for (i=0; i<n_neigh; i++) {
mat[i*n_neigh+j] = 0.0;
for (k=0; k<n_shared[i]; k++) {
mat[i*n_neigh+j] += DZ_IN[i][k] * pcis->work_N[shared[i][k]];
}
}
}
/* Complete the sending. */
if (n_neigh>1) {
MPI_Status *stat;
ierr = PetscMalloc((n_neigh-1)*sizeof(MPI_Status),&stat);CHKERRQ(ierr);
if (n_neigh-1) {ierr = MPI_Waitall(n_neigh-1,&(send_request[1]),stat);CHKERRQ(ierr);}
ierr = PetscFree(stat);CHKERRQ(ierr);
}
/* Free the memory for the MPI requests */
ierr = PetscFree(send_request);CHKERRQ(ierr);
/* Free the memory for DZ_OUT */
if (DZ_OUT) {
ierr = PetscFree(DZ_OUT[0]);CHKERRQ(ierr);
ierr = PetscFree(DZ_OUT);CHKERRQ(ierr);
}
{
PetscMPIInt size;
ierr = MPI_Comm_size(((PetscObject)pc)->comm,&size);CHKERRQ(ierr);
/* Create the global coarse vectors (rhs and solution). */
ierr = VecCreateMPI(((PetscObject)pc)->comm,1,size,&(pcnn->coarse_b));CHKERRQ(ierr);
ierr = VecDuplicate(pcnn->coarse_b,&(pcnn->coarse_x));CHKERRQ(ierr);
/* Create and set the global coarse AIJ matrix. */
ierr = MatCreate(((PetscObject)pc)->comm,&(pcnn->coarse_mat));CHKERRQ(ierr);
ierr = MatSetSizes(pcnn->coarse_mat,1,1,size,size);CHKERRQ(ierr);
ierr = MatSetType(pcnn->coarse_mat,MATAIJ);CHKERRQ(ierr);
ierr = MatSeqAIJSetPreallocation(pcnn->coarse_mat,1,PETSC_NULL);CHKERRQ(ierr);
ierr = MatMPIAIJSetPreallocation(pcnn->coarse_mat,1,PETSC_NULL,1,PETSC_NULL);CHKERRQ(ierr);
ierr = MatSetValues(pcnn->coarse_mat,n_neigh,neigh,n_neigh,neigh,mat,ADD_VALUES);CHKERRQ(ierr);
ierr = MatAssemblyBegin(pcnn->coarse_mat,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd (pcnn->coarse_mat,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
{
PetscMPIInt rank;
PetscScalar one = 1.0;
ierr = MPI_Comm_rank(((PetscObject)pc)->comm,&rank);CHKERRQ(ierr);
/* "Zero out" rows of not-purely-Neumann subdomains */
if (pcis->pure_neumann) { /* does NOT zero the row; create an empty index set. The reason is that MatZeroRows() is collective. */
ierr = MatZeroRows(pcnn->coarse_mat,0,PETSC_NULL,one,0,0);CHKERRQ(ierr);
} else { /* here it DOES zero the row, since it's not a floating subdomain. */
PetscInt row = (PetscInt) rank;
ierr = MatZeroRows(pcnn->coarse_mat,1,&row,one,0,0);CHKERRQ(ierr);
}
}
/* Create the coarse linear solver context */
{
PC pc_ctx, inner_pc;
KSP inner_ksp;
ierr = KSPCreate(((PetscObject)pc)->comm,&pcnn->ksp_coarse);CHKERRQ(ierr);
ierr = PetscObjectIncrementTabLevel((PetscObject)pcnn->ksp_coarse,(PetscObject)pc,2);CHKERRQ(ierr);
ierr = KSPSetOperators(pcnn->ksp_coarse,pcnn->coarse_mat,pcnn->coarse_mat,SAME_PRECONDITIONER);CHKERRQ(ierr);
ierr = KSPGetPC(pcnn->ksp_coarse,&pc_ctx);CHKERRQ(ierr);
ierr = PCSetType(pc_ctx,PCREDUNDANT);CHKERRQ(ierr);
ierr = KSPSetType(pcnn->ksp_coarse,KSPPREONLY);CHKERRQ(ierr);
ierr = PCRedundantGetKSP(pc_ctx,&inner_ksp);CHKERRQ(ierr);
ierr = KSPGetPC(inner_ksp,&inner_pc);CHKERRQ(ierr);
ierr = PCSetType(inner_pc,PCLU);CHKERRQ(ierr);
ierr = KSPSetOptionsPrefix(pcnn->ksp_coarse,"nn_coarse_");CHKERRQ(ierr);
ierr = KSPSetFromOptions(pcnn->ksp_coarse);CHKERRQ(ierr);
/* the vectors in the following line are dummy arguments, just telling the KSP the vector size. Values are not used */
ierr = KSPSetUp(pcnn->ksp_coarse);CHKERRQ(ierr);
}
/* Free the memory for mat */
ierr = PetscFree(mat);CHKERRQ(ierr);
/* for DEBUGGING, save the coarse matrix to a file. */
{
PetscBool flg = PETSC_FALSE;
ierr = PetscOptionsGetBool(PETSC_NULL,"-pc_nn_save_coarse_matrix",&flg,PETSC_NULL);CHKERRQ(ierr);
if (flg) {
PetscViewer viewer;
ierr = PetscViewerASCIIOpen(PETSC_COMM_WORLD,"coarse.m",&viewer);CHKERRQ(ierr);
ierr = PetscViewerSetFormat(viewer,PETSC_VIEWER_ASCII_MATLAB);CHKERRQ(ierr);
ierr = MatView(pcnn->coarse_mat,viewer);CHKERRQ(ierr);
ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr);
}
}
/* Set the variable pcnn->factor_coarse_rhs. */
pcnn->factor_coarse_rhs = (pcis->pure_neumann) ? 1.0 : 0.0;
/* See historical note 02, at the bottom of this file. */
PetscFunctionReturn(0);
}
