1 #define PETSC_DLL 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 PETSC_DLLEXPORT 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 PETSC_DLLEXPORT 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_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) { 94 SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 95 } 96 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 97 } 98 99 *tag = counter->tag--; 100 #if defined(PETSC_USE_DEBUG) 101 /* 102 Hanging here means that some processes have called PetscCommGetNewTag() and others have not. 103 */ 104 ierr = MPI_Barrier(comm);CHKERRQ(ierr); 105 #endif 106 PetscFunctionReturn(0); 107 } 108 109 #undef __FUNCT__ 110 #define __FUNCT__ "PetscCommDuplicate" 111 /*@C 112 PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator. 113 114 Collective on MPI_Comm 115 116 Input Parameters: 117 . comm_in - Input communicator 118 119 Output Parameters: 120 + comm_out - Output communicator. May be comm_in. 121 - first_tag - Tag available that has not already been used with this communicator (you may 122 pass in PETSC_NULL if you do not need a tag) 123 124 PETSc communicators are just regular MPI communicators that keep track of which 125 tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into 126 a PETSc creation routine it will attach a private communicator for use in the objects communications. 127 The internal MPI_Comm is used to perform all the MPI calls for PETSc, the outter MPI_Comm is a user 128 level MPI_Comm that may be performing communication for the user or other library and so IS NOT used by PETSc. 129 130 Level: developer 131 132 Concepts: communicator^duplicate 133 134 .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy() 135 @*/ 136 PetscErrorCode PETSC_DLLEXPORT PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag) 137 { 138 PetscErrorCode ierr; 139 PetscCommCounter *counter; 140 PetscMPIInt *maxval,flg; 141 142 PetscFunctionBegin; 143 ierr = MPI_Attr_get(comm_in,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 144 145 if (!flg) { /* this is NOT a PETSc comm */ 146 void *ptr; 147 /* check if this communicator has a PETSc communicator imbedded in it */ 148 ierr = MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 149 if (!flg) { 150 /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */ 151 ierr = MPI_Comm_dup(comm_in,comm_out);CHKERRQ(ierr); 152 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 153 if (!flg) { 154 SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 155 } 156 ierr = PetscMalloc(sizeof(PetscCommCounter),&counter);CHKERRQ(ierr); 157 counter->tag = *maxval; 158 counter->refcount = 0; 159 counter->namecount = 0; 160 ierr = MPI_Attr_put(*comm_out,Petsc_Counter_keyval,counter);CHKERRQ(ierr); 161 ierr = PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);CHKERRQ(ierr); 162 163 /* save PETSc communicator inside user communicator, so we can get it next time */ 164 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 165 ierr = PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));CHKERRQ(ierr); 166 ierr = MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);CHKERRQ(ierr); 167 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 168 ierr = PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));CHKERRQ(ierr); 169 ierr = MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);CHKERRQ(ierr); 170 } else { 171 /* pull out the inner MPI_Comm and hand it back to the caller */ 172 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 173 ierr = PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 174 ierr = MPI_Attr_get(*comm_out,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 175 if (!flg) { 176 SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set"); 177 } 178 ierr = PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);CHKERRQ(ierr); 179 } 180 } else { 181 *comm_out = comm_in; 182 } 183 184 #if defined(PETSC_USE_DEBUG) 185 /* 186 Hanging here means that some processes have called PetscCommDuplicate() and others have not. 187 This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject! 188 ALL processes that share a communicator MUST shared objects created from that communicator. 189 */ 190 ierr = MPI_Barrier(comm_in);CHKERRQ(ierr); 191 #endif 192 193 if (counter->tag < 1) { 194 ierr = PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);CHKERRQ(ierr); 195 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 196 if (!flg) { 197 SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 198 } 199 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 200 } 201 202 if (first_tag) { 203 *first_tag = counter->tag--; 204 ierr = PetscInfo1(0," returning tag %ld\n",(long)*first_tag);CHKERRQ(ierr); 205 } 206 counter->refcount++; /* number of references to this comm */ 207 PetscFunctionReturn(0); 208 } 209 210 #undef __FUNCT__ 211 #define __FUNCT__ "PetscCommDestroy" 212 /*@C 213 PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate(). 214 215 Collective on MPI_Comm 216 217 Input Parameter: 218 . comm - the communicator to free 219 220 Level: developer 221 222 Concepts: communicator^destroy 223 224 .seealso: PetscCommDuplicate() 225 @*/ 226 PetscErrorCode PETSC_DLLEXPORT PetscCommDestroy(MPI_Comm *comm) 227 { 228 PetscErrorCode ierr; 229 PetscCommCounter *counter; 230 PetscMPIInt flg; 231 MPI_Comm icomm = *comm,ocomm; 232 void *ptr; 233 234 PetscFunctionBegin; 235 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 236 if (!flg) { /* not a PETSc comm, check if it has an inner comm */ 237 ierr = MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 238 if (!flg) { 239 SETERRQ(PETSC_ERR_ARG_CORRUPT,"MPI_Comm does not have tag/name counter nor does it have inner MPI_Comm"); 240 } 241 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 242 ierr = PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 243 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 244 if (!flg) { 245 SETERRQ(PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory"); 246 } 247 } 248 counter->refcount--; 249 if (!counter->refcount) { 250 251 /* if MPI_Comm has outter comm then remove reference to inner MPI_Comm from outter MPI_Comm */ 252 ierr = MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,&flg);CHKERRQ(ierr); 253 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 254 ierr = PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 255 if (flg) { 256 ierr = MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);CHKERRQ(ierr); 257 } 258 259 ierr = PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);CHKERRQ(ierr); 260 ierr = MPI_Comm_free(&icomm);CHKERRQ(ierr); 261 } 262 PetscFunctionReturn(0); 263 } 264 265