static PetscErrorCode DMGetNeighbors_DA(DM dm, PetscInt *nranks, const PetscMPIInt *ranks[]) { PetscErrorCode ierr; PetscInt dim; DMDAStencilType st; PetscFunctionBegin; ierr = DMDAGetNeighbors(dm,ranks);CHKERRQ(ierr); ierr = DMDAGetInfo(dm,&dim,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,&st);CHKERRQ(ierr); switch (dim) { case 1: *nranks = 3; /* if (st == DMDA_STENCIL_STAR) { *nranks = 3; } */ break; case 2: *nranks = 9; /* if (st == DMDA_STENCIL_STAR) { *nranks = 5; } */ break; case 3: *nranks = 27; /* if (st == DMDA_STENCIL_STAR) { *nranks = 7; } */ break; default: break; } PetscFunctionReturn(0); }
PETSC_EXTERN void PETSC_STDCALL dmdagetneighbors_(DM *da,PetscMPIInt *ranks,PetscErrorCode *ierr) { const PetscMPIInt *r; PetscInt n; DM_DA *dd = (DM_DA*)(*da)->data; *ierr = DMDAGetNeighbors(*da,&r);if (*ierr) return; if (dd->dim == 2) n = 9; else n = 27; *ierr = PetscMemcpy(ranks,r,n*sizeof(PetscMPIInt)); }
PETSC_EXTERN void PETSC_STDCALL dmdagetneighbors_(DM *da,PetscMPIInt *ranks,PetscErrorCode *ierr) { const PetscMPIInt *r; PetscInt n,dim; *ierr = DMDAGetNeighbors(*da,&r);if (*ierr) return; *ierr = DMGetDimension(*da,&dim);if (*ierr) return; if (dim == 2) n = 9; else n = 27; *ierr = PetscMemcpy(ranks,r,n*sizeof(PetscMPIInt)); }
PetscErrorCode FiberField_AddToSendbufs( FiberField field ) { int i; int e; const int vlen = ArrayLength(field->verts); const int elen = ArrayLength(field->edges); const BoundingBox lbbox = field->localBounds; int neiIdx; VertexEdgeMPI *evmpi; iCoor n; // index in 3x3x3 array nei Vertex v; PetscMPIInt sendRank; const PetscMPIInt *neiRanks; PetscErrorCode ierr; PetscFunctionBegin; ierr = DMDAGetNeighbors(field->da, &neiRanks); CHKERRQ(ierr); // clear send arrays // for each vert // if outside nei, err // else add vert to send list for (i = 0; i < NUMNEI; i++) { ArraySetSize( field->sendbufs[i], 0); } for (i = 0; i < vlen; i++) { ierr = ArrayGet( field->verts, i, &v ); CHKERRQ(ierr); PositionToNeiIdx( &lbbox, &v->X, &n, &neiIdx); // if vertex outside 3x3x3 nei, something went terribly wrong if (n.x < 0 || n.x > 2 || n.y < 0 || n.y > 2 || n.z < 0 || n.z > 2 ) { ierr = PetscInfo(0, "ERROR: Vertex outside 3x3x3 neighbor region\n"); CHKERRQ(ierr); ierr = PetscInfo1(0, "i = %d\n",i); CHKERRQ(ierr); ierr = PetscInfo3(0, "X = {%f, %f, %f}\n",v->X.x,v->X.y,v->X.z); CHKERRQ(ierr); ierr = PetscInfo3(0, "n = {%d, %d, %d}\n",n.x,n.y,n.z); CHKERRQ(ierr); ierr = PetscInfo(0, "ERROR: END MESSAGE\n"); CHKERRQ(ierr); SETERRQ(field->comm, 0, "Vertex outside 3x3x3 neighbor region"); } else { // convert nei index to mpi rank sendRank = neiRanks[neiIdx]; // in the edge case where a vertex leaves the global bounding box, abort // handle this case in the physics, not in the communication routine if ( sendRank == MPI_PROC_NULL) { ierr = PetscInfo(0, "ERROR: Vertex outside global bbox\n"); CHKERRQ(ierr); ierr = PetscInfo1(0, "i = %d\n",i); CHKERRQ(ierr); ierr = PetscInfo3(0, "X = {%f, %f, %f}\n",v->X.x,v->X.y,v->X.z); CHKERRQ(ierr); ierr = PetscInfo3(0, "n = {%d, %d, %d}\n",n.x,n.y,n.z); CHKERRQ(ierr); ierr = PetscInfo1(0, "neiIdx = %d\n",neiIdx); CHKERRQ(ierr); ierr = PetscInfo(0, "ERROR: END MESSAGE\n"); CHKERRQ(ierr); SETERRQ(field->comm, 0, "Vertex outside global bbox\n"); } // add vertex to send list[rank] ierr = ArrayAppend( field->sendbufs[neiIdx], &evmpi); CHKERRQ(ierr); evmpi->xID = v->vID; evmpi->type= v->type; evmpi->X = v->X; evmpi->V = v->V; for (e = 0; e < MAXEDGES; e++) { evmpi->yIDs[e] = v->eID[e]; } } } int min; int vPO; struct _Edge *edges = ArrayGetData(field->edges); struct _Vertex *vertsPO; ierr = FiberFieldGetVertexArrayPO( field, &vertsPO ); CHKERRQ(ierr); for (e = 0; e < elen; e++) { // the edge is 'owned' by the vertex with the smallest ID min = edges[e].vID[0] < edges[e].vID[1] ? 0 : 1; vPO = edges[e].vPO[min]; v = &vertsPO[vPO]; PositionToNeiIdx( &lbbox, &v->X, &n, &neiIdx); if (v->vID != edges[e].vID[min] ) { ierr = PetscInfo1(0, "v->vID = %d\n", v->vID); CHKERRQ(ierr); ierr = PetscInfo1(0, "edges[e].vID[min] = %d\n", edges[e].vID[min]); CHKERRQ(ierr); SETERRQ(PETSC_COMM_SELF, 0, "Bad vertex"); } ierr = ArrayAppend( field->sendbufs[neiIdx], &evmpi); CHKERRQ(ierr); evmpi->xID = edges[e].eID; evmpi->type = edges[e].type; evmpi->yIDs[0] = edges[e].vID[0]; evmpi->yIDs[1] = edges[e].vID[1]; evmpi->X.x = edges[e].l0; } PetscFunctionReturn(0); }
PetscErrorCode FiberField_Nei_Alltoall( FiberField f ) { int i; int neiIdx; // index where nei[] == src int count; // probing count num elements received const int tag = 128456826; // TODO: should tag # be something unique for each call to this routine? const int NUMRECV = f->NUMRECV; Array *sendbufs = f->sendbufs; Array *recvbufs = f->recvbufs; MPI_Request reqSend[NUMNEI]; MPI_Request reqRecv[NUMNEI]; MPI_Status status; MPI_Comm comm = f->comm; const PetscMPIInt *neiRanks; PetscErrorCode ierr; PetscFunctionBegin; //TODO: why is this barrier necessary if all Isend/Irecv matched with WaitAll? //BUG: without barrier, sources from other iterations caught in probe ierr = PetscBarrier(0); CHKERRQ(ierr); ierr = DMDAGetNeighbors(f->da, &neiRanks); CHKERRQ(ierr); // send verts to neighbors for (i = 0; i < NUMNEI; i++) { count = ArrayLength(sendbufs[i]); ierr = MPI_Isend(ArrayGetData(sendbufs[i]), count, f->vertmpitype, neiRanks[i], tag, comm, &reqSend[i] ); CHKERRQ(ierr); /*ierr = MPI_Send(ArrayGetData(sendbufs[i]), count, f->vertmpitype, neiRanks[i], tag, comm ); CHKERRQ(ierr);*/ #ifdef DEBUG_ALLTOALL ierr = PetscInfo1(0, "i = %d\n", i ); CHKERRQ(ierr); ierr = PetscInfo1(0, "dst = %d\n", neiRanks[i] ); CHKERRQ(ierr); ierr = PetscInfo1(0, "count = %d\n", ArrayLength(sendbufs[i]) ); CHKERRQ(ierr); #endif } // receive verts from neighbors for (i = 0; i < NUMRECV; i++) { // probe for count verts sent ierr = MPI_Probe(MPI_ANY_SOURCE, tag, comm, &status); CHKERRQ(ierr); ierr = MPI_Get_count( &status, f->vertmpitype, &count); CHKERRQ(ierr); // convert source rank into nei index (for recvbufs array) for (neiIdx = 0; neiIdx < NUMNEI; neiIdx++) { if( neiRanks[neiIdx] == status.MPI_SOURCE ) break; } #ifdef DEBUG_ALLTOALL ierr = PetscInfo1(0, "i = %d\n", i ); CHKERRQ(ierr); ierr = PetscInfo1(0, "src = %d\n", status.MPI_SOURCE ); CHKERRQ(ierr); ierr = PetscInfo1(0, "count = %d\n", count ); CHKERRQ(ierr); #endif ierr = ArraySetSize( recvbufs[neiIdx], count); CHKERRQ(ierr); ierr = MPI_Irecv( ArrayGetData(recvbufs[neiIdx]), count, f->vertmpitype, status.MPI_SOURCE, tag, comm, &reqRecv[i]); CHKERRQ(ierr); /*ierr = MPI_Recv( ArrayGetData(recvbufs[neiIdx]), count, f->vertmpitype, status.MPI_SOURCE, tag, comm, &status ); CHKERRQ(ierr);*/ } ierr = MPI_Waitall( NUMRECV, reqRecv, MPI_STATUSES_IGNORE ); CHKERRQ(ierr); ierr = MPI_Waitall( NUMNEI, reqSend, MPI_STATUSES_IGNORE ); CHKERRQ(ierr); PetscFunctionReturn(0); }