Actual source code: tagm.c
1: #include <petsc/private/petscimpl.h>
2: /* ---------------------------------------------------------------- */
3: /*
4: A simple way to manage tags inside a communicator.
6: It uses the attributes to determine if a new communicator
7: is needed and to store the available tags.
9: */
11: /*@C
12: PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All
13: processors that share the object MUST call this routine EXACTLY the same
14: number of times. This tag should only be used with the current objects
15: communicator; do NOT use it with any other MPI communicator.
17: Collective on PetscObject
19: Input Parameter:
20: . obj - the PETSc object; this must be cast with a (PetscObject), for example,
21: PetscObjectGetNewTag((PetscObject)mat,&tag);
23: Output Parameter:
24: . tag - the new tag
26: Level: developer
28: .seealso: PetscCommGetNewTag()
29: @*/
30: PetscErrorCode PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
31: {
32: PetscCommGetNewTag(obj->comm,tag);
33: return 0;
34: }
36: /*@
37: PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All
38: processors that share the communicator MUST call this routine EXACTLY the same
39: number of times. This tag should only be used with the current objects
40: communicator; do NOT use it with any other MPI communicator.
42: Collective
44: Input Parameter:
45: . comm - the MPI communicator
47: Output Parameter:
48: . tag - the new tag
50: Level: developer
52: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
53: @*/
54: PetscErrorCode PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
55: {
56: PetscCommCounter *counter;
57: PetscMPIInt *maxval,flg;
61: MPI_Comm_get_attr(comm,Petsc_Counter_keyval,&counter,&flg);
64: if (counter->tag < 1) {
66: PetscInfo(NULL,"Out of tags for object, starting to recycle. Comm reference count %" PetscInt_FMT "\n",counter->refcount);
67: MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
69: counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
70: }
72: *tag = counter->tag--;
73: if (PetscDefined(USE_DEBUG)) {
74: /*
75: Hanging here means that some processes have called PetscCommGetNewTag() and others have not.
76: */
77: MPI_Barrier(comm);
78: }
79: return 0;
80: }
82: /*@C
83: PetscCommGetComm - get an MPI communicator from a PETSc communicator that can be passed off to another package
85: Collective
87: Input Parameter:
88: . comm_in - Input communicator
90: Output Parameters:
91: . comm_out - Output communicator
93: Notes:
94: Use PetscCommRestoreComm() to return the communicator when the external package no longer needs it
96: Certain MPI implementations have MPI_Comm_free() that do not work, thus one can run out of available MPI communicators causing
97: mysterious crashes in the code after running a long time. This routine allows reusing previously obtained MPI communicators that
98: are no longer needed.
100: Level: developer
102: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy(), PetscCommRestoreComm()
103: @*/
104: PetscErrorCode PetscCommGetComm(MPI_Comm comm_in,MPI_Comm *comm_out)
105: {
106: PetscCommCounter *counter;
107: PetscMPIInt flg;
109: PetscSpinlockLock(&PetscCommSpinLock);
110: MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);
113: if (counter->comms) {
114: struct PetscCommStash *pcomms = counter->comms;
116: *comm_out = pcomms->comm;
117: counter->comms = pcomms->next;
118: PetscFree(pcomms);
119: PetscInfo(NULL,"Reusing a communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
120: } else {
121: MPI_Comm_dup(comm_in,comm_out);
122: }
123: PetscSpinlockUnlock(&PetscCommSpinLock);
124: return 0;
125: }
127: /*@C
128: PetscCommRestoreComm - restores an MPI communicator that was obtained with PetscCommGetComm()
130: Collective
132: Input Parameters:
133: + comm_in - Input communicator
134: - comm_out - returned communicator
136: Level: developer
138: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy(), PetscCommRestoreComm()
139: @*/
140: PetscErrorCode PetscCommRestoreComm(MPI_Comm comm_in,MPI_Comm *comm_out)
141: {
142: PetscCommCounter *counter;
143: PetscMPIInt flg;
144: struct PetscCommStash *pcomms,*ncomm;
146: PetscSpinlockLock(&PetscCommSpinLock);
147: MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);
150: PetscMalloc(sizeof(struct PetscCommStash),&ncomm);
151: ncomm->comm = *comm_out;
152: ncomm->next = NULL;
153: pcomms = counter->comms;
154: while (pcomms && pcomms->next) pcomms = pcomms->next;
155: if (pcomms) {
156: pcomms->next = ncomm;
157: } else {
158: counter->comms = ncomm;
159: }
160: *comm_out = 0;
161: PetscSpinlockUnlock(&PetscCommSpinLock);
162: return 0;
163: }
165: /*@C
166: PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator.
168: Collective
170: Input Parameter:
171: . comm_in - Input communicator
173: Output Parameters:
174: + comm_out - Output communicator. May be comm_in.
175: - first_tag - Tag available that has not already been used with this communicator (you may
176: pass in NULL if you do not need a tag)
178: PETSc communicators are just regular MPI communicators that keep track of which
179: tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
180: a PETSc creation routine it will attach a private communicator for use in the objects communications.
181: The internal MPI_Comm is used to perform all the MPI calls for PETSc, the outer MPI_Comm is a user
182: level MPI_Comm that may be performing communication for the user or other library and so IS NOT used by PETSc.
184: Level: developer
186: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy()
187: @*/
188: PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt *first_tag)
189: {
190: PetscCommCounter *counter;
191: PetscMPIInt *maxval,flg;
193: PetscSpinlockLock(&PetscCommSpinLock);
194: MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);
196: if (!flg) { /* this is NOT a PETSc comm */
197: union {MPI_Comm comm; void *ptr;} ucomm;
198: /* check if this communicator has a PETSc communicator embedded in it */
199: MPI_Comm_get_attr(comm_in,Petsc_InnerComm_keyval,&ucomm,&flg);
200: if (!flg) {
201: /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
202: MPI_Comm_dup(comm_in,comm_out);
203: MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
205: PetscNew(&counter); /* all fields of counter are zero'ed */
206: counter->tag = *maxval;
207: MPI_Comm_set_attr(*comm_out,Petsc_Counter_keyval,counter);
208: PetscInfo(NULL,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);
210: /* save PETSc communicator inside user communicator, so we can get it next time */
211: ucomm.comm = *comm_out; /* ONLY the comm part of the union is significant. */
212: MPI_Comm_set_attr(comm_in,Petsc_InnerComm_keyval,ucomm.ptr);
213: ucomm.comm = comm_in;
214: MPI_Comm_set_attr(*comm_out,Petsc_OuterComm_keyval,ucomm.ptr);
215: } else {
216: *comm_out = ucomm.comm;
217: /* pull out the inner MPI_Comm and hand it back to the caller */
218: MPI_Comm_get_attr(*comm_out,Petsc_Counter_keyval,&counter,&flg);
220: PetscInfo(NULL,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
221: }
222: } else *comm_out = comm_in;
224: if (PetscDefined(USE_DEBUG)) {
225: /*
226: Hanging here means that some processes have called PetscCommDuplicate() and others have not.
227: This likely means that a subset of processes in a MPI_Comm have attempted to create a PetscObject!
228: ALL processes that share a communicator MUST shared objects created from that communicator.
229: */
230: MPI_Barrier(comm_in);
231: }
233: if (counter->tag < 1) {
234: PetscInfo(NULL,"Out of tags for object, starting to recycle. Comm reference count %" PetscInt_FMT "\n",counter->refcount);
235: MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
237: counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
238: }
240: if (first_tag) *first_tag = counter->tag--;
242: counter->refcount++; /* number of references to this comm */
243: PetscSpinlockUnlock(&PetscCommSpinLock);
244: return 0;
245: }
247: /*@C
248: PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate().
250: Collective
252: Input Parameter:
253: . comm - the communicator to free
255: Level: developer
257: .seealso: PetscCommDuplicate()
258: @*/
259: PetscErrorCode PetscCommDestroy(MPI_Comm *comm)
260: {
261: PetscCommCounter *counter;
262: PetscMPIInt flg;
263: MPI_Comm icomm = *comm,ocomm;
264: union {MPI_Comm comm; void *ptr;} ucomm;
266: if (*comm == MPI_COMM_NULL) return 0;
267: PetscSpinlockLock(&PetscCommSpinLock);
268: MPI_Comm_get_attr(icomm,Petsc_Counter_keyval,&counter,&flg);
269: if (!flg) { /* not a PETSc comm, check if it has an inner comm */
270: MPI_Comm_get_attr(icomm,Petsc_InnerComm_keyval,&ucomm,&flg);
272: icomm = ucomm.comm;
273: MPI_Comm_get_attr(icomm,Petsc_Counter_keyval,&counter,&flg);
275: }
277: counter->refcount--;
279: if (!counter->refcount) {
280: /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
281: MPI_Comm_get_attr(icomm,Petsc_OuterComm_keyval,&ucomm,&flg);
282: if (flg) {
283: ocomm = ucomm.comm;
284: MPI_Comm_get_attr(ocomm,Petsc_InnerComm_keyval,&ucomm,&flg);
285: if (flg) {
286: MPI_Comm_delete_attr(ocomm,Petsc_InnerComm_keyval);
287: } else SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Outer MPI_Comm %ld does not have expected reference to inner comm %ld, problem with corrupted memory",(long int)ocomm,(long int)icomm);
288: }
290: PetscInfo(NULL,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);
291: MPI_Comm_free(&icomm);
292: }
293: *comm = MPI_COMM_NULL;
294: PetscSpinlockUnlock(&PetscCommSpinLock);
295: return 0;
296: }
298: /*@C
299: PetscObjectsListGetGlobalNumbering - computes a global numbering
300: of PetscObjects living on subcommunicators of a given communicator.
302: Collective.
304: Input Parameters:
305: + comm - MPI_Comm
306: . len - local length of objlist
307: - objlist - a list of PETSc objects living on subcomms of comm and containing this comm rank
308: (subcomm ordering is assumed to be deadlock-free)
310: Output Parameters:
311: + count - global number of distinct subcommunicators on objlist (may be > len)
312: - numbering - global numbers of objlist entries (allocated by user)
314: Level: developer
316: @*/
317: PetscErrorCode PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering)
318: {
319: PetscInt i, roots, offset;
320: PetscMPIInt size, rank;
323: if (!count && !numbering) return 0;
325: MPI_Comm_size(comm, &size);
326: MPI_Comm_rank(comm, &rank);
327: roots = 0;
328: for (i = 0; i < len; ++i) {
329: PetscMPIInt srank;
330: MPI_Comm_rank(objlist[i]->comm, &srank);
331: /* Am I the root of the i-th subcomm? */
332: if (!srank) ++roots;
333: }
334: if (count) {
335: /* Obtain the sum of all roots -- the global number of distinct subcomms. */
336: MPIU_Allreduce(&roots,count,1,MPIU_INT,MPI_SUM,comm);
337: }
338: if (numbering) {
339: /* Introduce a global numbering for subcomms, initially known only by subcomm roots. */
340: /*
341: At each subcomm root number all of the subcomms it owns locally
342: and make it global by calculating the shift among all of the roots.
343: The roots are ordered using the comm ordering.
344: */
345: MPI_Scan(&roots,&offset,1,MPIU_INT,MPI_SUM,comm);
346: offset -= roots;
347: /* Now we are ready to broadcast global subcomm numbers within each subcomm.*/
348: /*
349: This is where the assumption of a deadlock-free ordering of the subcomms is assumed:
350: broadcast is collective on the subcomm.
351: */
352: roots = 0;
353: for (i = 0; i < len; ++i) {
354: PetscMPIInt srank;
355: numbering[i] = offset + roots; /* only meaningful if !srank. */
357: MPI_Comm_rank(objlist[i]->comm, &srank);
358: MPI_Bcast(numbering+i,1,MPIU_INT,0,objlist[i]->comm);
359: if (!srank) ++roots;
360: }
361: }
362: return 0;
363: }