Actual source code: tagm.c
petsc-3.13.6 2020-09-29
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: */
12: /*@C
13: PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All
14: processors that share the object MUST call this routine EXACTLY the same
15: number of times. This tag should only be used with the current objects
16: communicator; do NOT use it with any other MPI communicator.
18: Collective on PetscObject
20: Input Parameter:
21: . obj - the PETSc object; this must be cast with a (PetscObject), for example,
22: PetscObjectGetNewTag((PetscObject)mat,&tag);
24: Output Parameter:
25: . tag - the new tag
27: Level: developer
29: .seealso: PetscCommGetNewTag()
30: @*/
31: PetscErrorCode PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
32: {
36: PetscCommGetNewTag(obj->comm,tag);
37: return(0);
38: }
40: /*@
41: PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All
42: processors that share the communicator MUST call this routine EXACTLY the same
43: number of times. This tag should only be used with the current objects
44: communicator; do NOT use it with any other MPI communicator.
46: Collective
48: Input Parameter:
49: . comm - the MPI communicator
51: Output Parameter:
52: . tag - the new tag
54: Level: developer
56: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
57: @*/
58: PetscErrorCode PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
59: {
60: PetscErrorCode ierr;
61: PetscCommCounter *counter;
62: PetscMPIInt *maxval,flg;
67: MPI_Comm_get_attr(comm,Petsc_Counter_keyval,&counter,&flg);
68: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");
70: if (counter->tag < 1) {
71: PetscInfo1(NULL,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);
72: MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
73: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
74: counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
75: }
77: *tag = counter->tag--;
78: #if defined(PETSC_USE_DEBUG)
79: /*
80: Hanging here means that some processes have called PetscCommGetNewTag() and others have not.
81: */
82: MPI_Barrier(comm);
83: #endif
84: return(0);
85: }
87: /*@C
88: PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator.
90: Collective
92: Input Parameters:
93: . comm_in - Input communicator
95: Output Parameters:
96: + comm_out - Output communicator. May be comm_in.
97: - first_tag - Tag available that has not already been used with this communicator (you may
98: pass in NULL if you do not need a tag)
100: PETSc communicators are just regular MPI communicators that keep track of which
101: tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
102: a PETSc creation routine it will attach a private communicator for use in the objects communications.
103: The internal MPI_Comm is used to perform all the MPI calls for PETSc, the outer MPI_Comm is a user
104: level MPI_Comm that may be performing communication for the user or other library and so IS NOT used by PETSc.
106: Level: developer
108: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy()
109: @*/
110: PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt *first_tag)
111: {
112: PetscErrorCode ierr;
113: PetscCommCounter *counter;
114: PetscMPIInt *maxval,flg;
117: PetscSpinlockLock(&PetscCommSpinLock);
118: MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);
120: if (!flg) { /* this is NOT a PETSc comm */
121: union {MPI_Comm comm; void *ptr;} ucomm;
122: /* check if this communicator has a PETSc communicator imbedded in it */
123: MPI_Comm_get_attr(comm_in,Petsc_InnerComm_keyval,&ucomm,&flg);
124: if (!flg) {
125: /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
126: MPI_Comm_dup(comm_in,comm_out);
127: MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
128: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
129: PetscNew(&counter); /* all fields of counter are zero'ed */
130: counter->tag = *maxval;
131: MPI_Comm_set_attr(*comm_out,Petsc_Counter_keyval,counter);
132: PetscInfo3(NULL,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);
134: /* save PETSc communicator inside user communicator, so we can get it next time */
135: ucomm.comm = *comm_out; /* ONLY the comm part of the union is significant. */
136: MPI_Comm_set_attr(comm_in,Petsc_InnerComm_keyval,ucomm.ptr);
137: ucomm.comm = comm_in;
138: MPI_Comm_set_attr(*comm_out,Petsc_OuterComm_keyval,ucomm.ptr);
139: } else {
140: *comm_out = ucomm.comm;
141: /* pull out the inner MPI_Comm and hand it back to the caller */
142: MPI_Comm_get_attr(*comm_out,Petsc_Counter_keyval,&counter,&flg);
143: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set");
144: PetscInfo2(NULL,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
145: }
146: } else *comm_out = comm_in;
148: #if defined(PETSC_USE_DEBUG)
149: /*
150: Hanging here means that some processes have called PetscCommDuplicate() and others have not.
151: This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject!
152: ALL processes that share a communicator MUST shared objects created from that communicator.
153: */
154: MPI_Barrier(comm_in);
155: #endif
157: if (counter->tag < 1) {
158: PetscInfo1(NULL,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);
159: MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
160: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
161: counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
162: }
164: if (first_tag) *first_tag = counter->tag--;
166: counter->refcount++; /* number of references to this comm */
167: PetscSpinlockUnlock(&PetscCommSpinLock);
168: return(0);
169: }
171: /*@C
172: PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate().
174: Collective
176: Input Parameter:
177: . comm - the communicator to free
179: Level: developer
181: .seealso: PetscCommDuplicate()
182: @*/
183: PetscErrorCode PetscCommDestroy(MPI_Comm *comm)
184: {
185: PetscErrorCode ierr;
186: PetscCommCounter *counter;
187: PetscMPIInt flg;
188: MPI_Comm icomm = *comm,ocomm;
189: union {MPI_Comm comm; void *ptr;} ucomm;
192: if (*comm == MPI_COMM_NULL) return(0);
193: PetscSpinlockLock(&PetscCommSpinLock);
194: MPI_Comm_get_attr(icomm,Petsc_Counter_keyval,&counter,&flg);
195: if (!flg) { /* not a PETSc comm, check if it has an inner comm */
196: MPI_Comm_get_attr(icomm,Petsc_InnerComm_keyval,&ucomm,&flg);
197: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"MPI_Comm does not have tag/name counter nor does it have inner MPI_Comm");
198: icomm = ucomm.comm;
199: MPI_Comm_get_attr(icomm,Petsc_Counter_keyval,&counter,&flg);
200: if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory");
201: }
203: counter->refcount--;
205: if (!counter->refcount) {
206: /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
207: MPI_Comm_get_attr(icomm,Petsc_OuterComm_keyval,&ucomm,&flg);
208: if (flg) {
209: ocomm = ucomm.comm;
210: MPI_Comm_get_attr(ocomm,Petsc_InnerComm_keyval,&ucomm,&flg);
211: if (flg) {
212: MPI_Comm_delete_attr(ocomm,Petsc_InnerComm_keyval);
213: } else SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Outer MPI_Comm %ld does not have expected reference to inner comm %d, problem with corrupted memory",(long int)ocomm,(long int)icomm);
214: }
216: PetscInfo1(NULL,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);
217: MPI_Comm_free(&icomm);
218: }
219: *comm = MPI_COMM_NULL;
220: PetscSpinlockUnlock(&PetscCommSpinLock);
221: return(0);
222: }
224: /*@C
225: PetscObjectsListGetGlobalNumbering - computes a global numbering
226: of PetscObjects living on subcommunicators of a given communicator.
229: Collective.
231: Input Parameters:
232: + comm - MPI_Comm
233: . len - local length of objlist
234: - objlist - a list of PETSc objects living on subcomms of comm and containing this comm rank
235: (subcomm ordering is assumed to be deadlock-free)
237: Output Parameters:
238: + count - global number of distinct subcommunicators on objlist (may be > len)
239: - numbering - global numbers of objlist entries (allocated by user)
242: Level: developer
244: @*/
245: PetscErrorCode PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering)
246: {
248: PetscInt i, roots, offset;
249: PetscMPIInt size, rank;
253: if (!count && !numbering) return(0);
255: MPI_Comm_size(comm, &size);
256: MPI_Comm_rank(comm, &rank);
257: roots = 0;
258: for (i = 0; i < len; ++i) {
259: PetscMPIInt srank;
260: MPI_Comm_rank(objlist[i]->comm, &srank);
261: /* Am I the root of the i-th subcomm? */
262: if (!srank) ++roots;
263: }
264: if (count) {
265: /* Obtain the sum of all roots -- the global number of distinct subcomms. */
266: MPIU_Allreduce(&roots,count,1,MPIU_INT,MPI_SUM,comm);
267: }
268: if (numbering){
269: /* Introduce a global numbering for subcomms, initially known only by subcomm roots. */
270: /*
271: At each subcomm root number all of the subcomms it owns locally
272: and make it global by calculating the shift among all of the roots.
273: The roots are ordered using the comm ordering.
274: */
275: MPI_Scan(&roots,&offset,1,MPIU_INT,MPI_SUM,comm);
276: offset -= roots;
277: /* Now we are ready to broadcast global subcomm numbers within each subcomm.*/
278: /*
279: This is where the assumption of a deadlock-free ordering of the subcomms is assumed:
280: broadcast is collective on the subcomm.
281: */
282: roots = 0;
283: for (i = 0; i < len; ++i) {
284: PetscMPIInt srank;
285: numbering[i] = offset + roots; /* only meaningful if !srank. */
287: MPI_Comm_rank(objlist[i]->comm, &srank);
288: MPI_Bcast(numbering+i,1,MPIU_INT,0,objlist[i]->comm);
289: if (!srank) ++roots;
290: }
291: }
292: return(0);
293: }