1 2 /* 3 Some PETSc utilites 4 */ 5 #include <petscsys.h> /*I "petscsys.h" I*/ 6 #if defined(PETSC_HAVE_STDLIB_H) 7 #include <stdlib.h> 8 #endif 9 10 /* ---------------------------------------------------------------- */ 11 /* 12 A simple way to manage tags inside a communicator. 13 14 It uses the attributes to determine if a new communicator 15 is needed and to store the available tags. 16 17 */ 18 19 20 #undef __FUNCT__ 21 #define __FUNCT__ "PetscObjectGetNewTag" 22 /*@C 23 PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All 24 processors that share the object MUST call this routine EXACTLY the same 25 number of times. This tag should only be used with the current objects 26 communicator; do NOT use it with any other MPI communicator. 27 28 Collective on PetscObject 29 30 Input Parameter: 31 . obj - the PETSc object; this must be cast with a (PetscObject), for example, 32 PetscObjectGetNewTag((PetscObject)mat,&tag); 33 34 Output Parameter: 35 . tag - the new tag 36 37 Level: developer 38 39 Concepts: tag^getting 40 Concepts: message tag^getting 41 Concepts: MPI message tag^getting 42 43 .seealso: PetscCommGetNewTag() 44 @*/ 45 PetscErrorCode PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag) 46 { 47 PetscErrorCode ierr; 48 49 PetscFunctionBegin; 50 ierr = PetscCommGetNewTag(obj->comm,tag);CHKERRQ(ierr); 51 PetscFunctionReturn(0); 52 } 53 54 #undef __FUNCT__ 55 #define __FUNCT__ "PetscCommGetNewTag" 56 /*@ 57 PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All 58 processors that share the communicator MUST call this routine EXACTLY the same 59 number of times. This tag should only be used with the current objects 60 communicator; do NOT use it with any other MPI communicator. 61 62 Collective on comm 63 64 Input Parameter: 65 . comm - the MPI communicator 66 67 Output Parameter: 68 . tag - the new tag 69 70 Level: developer 71 72 Concepts: tag^getting 73 Concepts: message tag^getting 74 Concepts: MPI message tag^getting 75 76 .seealso: PetscObjectGetNewTag(), PetscCommDuplicate() 77 @*/ 78 PetscErrorCode PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag) 79 { 80 PetscErrorCode ierr; 81 PetscCommCounter *counter; 82 PetscMPIInt *maxval,flg; 83 84 PetscFunctionBegin; 85 PetscValidIntPointer(tag,2); 86 87 ierr = MPI_Attr_get(comm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 88 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator"); 89 90 if (counter->tag < 1) { 91 ierr = PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);CHKERRQ(ierr); 92 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 93 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 94 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 95 } 96 97 *tag = counter->tag--; 98 #if defined(PETSC_USE_DEBUG) 99 /* 100 Hanging here means that some processes have called PetscCommGetNewTag() and others have not. 101 */ 102 ierr = MPI_Barrier(comm);CHKERRQ(ierr); 103 #endif 104 PetscFunctionReturn(0); 105 } 106 107 #undef __FUNCT__ 108 #define __FUNCT__ "PetscCommDuplicate" 109 /*@C 110 PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator. 111 112 Collective on MPI_Comm 113 114 Input Parameters: 115 . comm_in - Input communicator 116 117 Output Parameters: 118 + comm_out - Output communicator. May be comm_in. 119 - first_tag - Tag available that has not already been used with this communicator (you may 120 pass in PETSC_NULL if you do not need a tag) 121 122 PETSc communicators are just regular MPI communicators that keep track of which 123 tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into 124 a PETSc creation routine it will attach a private communicator for use in the objects communications. 125 The internal MPI_Comm is used to perform all the MPI calls for PETSc, the outer MPI_Comm is a user 126 level MPI_Comm that may be performing communication for the user or other library and so IS NOT used by PETSc. 127 128 Level: developer 129 130 Concepts: communicator^duplicate 131 132 .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy() 133 @*/ 134 PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag) 135 { 136 PetscErrorCode ierr; 137 PetscCommCounter *counter; 138 PetscMPIInt *maxval,flg; 139 140 PetscFunctionBegin; 141 ierr = MPI_Attr_get(comm_in,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 142 143 if (!flg) { /* this is NOT a PETSc comm */ 144 void *ptr; 145 /* check if this communicator has a PETSc communicator imbedded in it */ 146 ierr = MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 147 if (!flg) { 148 /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */ 149 ierr = MPI_Comm_dup(comm_in,comm_out);CHKERRQ(ierr); 150 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 151 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 152 ierr = PetscMalloc(sizeof(PetscCommCounter),&counter);CHKERRQ(ierr); 153 counter->tag = *maxval; 154 counter->refcount = 0; 155 counter->namecount = 0; 156 ierr = MPI_Attr_put(*comm_out,Petsc_Counter_keyval,counter);CHKERRQ(ierr); 157 ierr = PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);CHKERRQ(ierr); 158 159 /* save PETSc communicator inside user communicator, so we can get it next time */ 160 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 161 ierr = PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));CHKERRQ(ierr); 162 ierr = MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);CHKERRQ(ierr); 163 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 164 ierr = PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));CHKERRQ(ierr); 165 ierr = MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);CHKERRQ(ierr); 166 } else { 167 /* pull out the inner MPI_Comm and hand it back to the caller */ 168 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 169 ierr = PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 170 ierr = MPI_Attr_get(*comm_out,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 171 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set"); 172 ierr = PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);CHKERRQ(ierr); 173 } 174 } else { 175 *comm_out = comm_in; 176 } 177 178 #if defined(PETSC_USE_DEBUG) 179 /* 180 Hanging here means that some processes have called PetscCommDuplicate() and others have not. 181 This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject! 182 ALL processes that share a communicator MUST shared objects created from that communicator. 183 */ 184 ierr = MPI_Barrier(comm_in);CHKERRQ(ierr); 185 #endif 186 187 if (counter->tag < 1) { 188 ierr = PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);CHKERRQ(ierr); 189 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 190 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 191 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 192 } 193 194 if (first_tag) { 195 *first_tag = counter->tag--; 196 } 197 counter->refcount++; /* number of references to this comm */ 198 PetscFunctionReturn(0); 199 } 200 201 #undef __FUNCT__ 202 #define __FUNCT__ "PetscCommDestroy" 203 /*@C 204 PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate(). 205 206 Collective on MPI_Comm 207 208 Input Parameter: 209 . comm - the communicator to free 210 211 Level: developer 212 213 Concepts: communicator^destroy 214 215 .seealso: PetscCommDuplicate() 216 @*/ 217 PetscErrorCode PetscCommDestroy(MPI_Comm *comm) 218 { 219 PetscErrorCode ierr; 220 PetscCommCounter *counter; 221 PetscMPIInt flg; 222 MPI_Comm icomm = *comm,ocomm; 223 void *ptr; 224 225 PetscFunctionBegin; 226 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 227 if (!flg) { /* not a PETSc comm, check if it has an inner comm */ 228 ierr = MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 229 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"); 230 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 231 ierr = PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 232 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 233 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory"); 234 } 235 counter->refcount--; 236 if (!counter->refcount) { 237 238 /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */ 239 ierr = MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,&flg);CHKERRQ(ierr); 240 if (flg) { 241 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 242 ierr = PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 243 ierr = MPI_Attr_get(ocomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 244 if (flg) { 245 ierr = MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);CHKERRQ(ierr); 246 } 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); 247 } 248 249 ierr = PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);CHKERRQ(ierr); 250 ierr = MPI_Comm_free(&icomm);CHKERRQ(ierr); 251 } 252 *comm = 0; 253 PetscFunctionReturn(0); 254 } 255 256