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 Notes on the implementation 18 19 The tagvalues to use are stored in a two element array. The first element 20 is the first free tag value. The second is used to indicate how 21 many "copies" of the communicator there are used in destroying. 22 23 24 */ 25 26 static PetscMPIInt Petsc_Tag_keyval = MPI_KEYVAL_INVALID; 27 static PetscMPIInt Petsc_InnerComm_keyval = MPI_KEYVAL_INVALID; 28 static PetscMPIInt Petsc_OuterComm_keyval = MPI_KEYVAL_INVALID; 29 EXTERN_C_BEGIN 30 #undef __FUNCT__ 31 #define __FUNCT__ "Petsc_DelTag" 32 /* 33 Private routine to delete internal storage when a communicator is freed. 34 This is called by MPI, not by users. 35 36 Note: this is declared extern "C" because it is passed to the system routine signal() 37 which is an extern "C" routine. 38 */ 39 PetscMPIInt PETSC_DLLEXPORT Petsc_DelTag(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state) 40 { 41 PetscErrorCode ierr; 42 43 PetscFunctionBegin; 44 ierr = PetscLogInfo((0,"Petsc_DelTag:Deleting tag data in an MPI_Comm %ld\n",(long)comm));if (ierr) PetscFunctionReturn((PetscMPIInt)ierr); 45 ierr = PetscFree(attr_val);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr); 46 PetscFunctionReturn(MPI_SUCCESS); 47 } 48 EXTERN_C_END 49 50 EXTERN_C_BEGIN 51 #undef __FUNCT__ 52 #define __FUNCT__ "Petsc_DelComm" 53 /* 54 Private routine to delete internal storage when a communicator is freed. 55 This is called by MPI, not by users. 56 57 Note: this is declared extern "C" because it is passed to the system routine signal() 58 which is an extern "C" routine. 59 */ 60 PetscMPIInt PETSC_DLLEXPORT Petsc_DelComm(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state) 61 { 62 PetscErrorCode ierr; 63 64 PetscFunctionBegin; 65 ierr = PetscLogInfo((0,"Petsc_DelComm:Deleting PETSc communicator imbedded in a user MPI_Comm %ld\n",(long)comm));if (ierr) PetscFunctionReturn((PetscMPIInt)ierr); 66 /* actually don't delete anything because we cannot increase the reference count of the communicator anyways */ 67 PetscFunctionReturn(MPI_SUCCESS); 68 } 69 EXTERN_C_END 70 71 #undef __FUNCT__ 72 #define __FUNCT__ "PetscObjectGetNewTag" 73 /*@C 74 PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All 75 processors that share the object MUST call this routine EXACTLY the same 76 number of times. This tag should only be used with the current objects 77 communicator; do NOT use it with any other MPI communicator. 78 79 Collective on PetscObject 80 81 Input Parameter: 82 . obj - the PETSc object; this must be cast with a (PetscObject), for example, 83 PetscObjectGetNewTag((PetscObject)mat,&tag); 84 85 Output Parameter: 86 . tag - the new tag 87 88 Level: developer 89 90 Concepts: tag^getting 91 Concepts: message tag^getting 92 Concepts: MPI message tag^getting 93 94 .seealso: PetscCommGetNewTag() 95 @*/ 96 PetscErrorCode PETSC_DLLEXPORT PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag) 97 { 98 PetscErrorCode ierr; 99 100 PetscFunctionBegin; 101 ierr = PetscCommGetNewTag(obj->comm,tag);CHKERRQ(ierr); 102 PetscFunctionReturn(0); 103 } 104 105 #undef __FUNCT__ 106 #define __FUNCT__ "PetscCommGetNewTag" 107 /*@ 108 PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All 109 processors that share the communicator MUST call this routine EXACTLY the same 110 number of times. This tag should only be used with the current objects 111 communicator; do NOT use it with any other MPI communicator. 112 113 Collective on comm 114 115 Input Parameter: 116 . comm - the PETSc communicator 117 118 Output Parameter: 119 . tag - the new tag 120 121 Level: developer 122 123 Concepts: tag^getting 124 Concepts: message tag^getting 125 Concepts: MPI message tag^getting 126 127 .seealso: PetscObjectGetNewTag(), PetscCommDuplicate() 128 @*/ 129 PetscErrorCode PETSC_DLLEXPORT PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag) 130 { 131 PetscErrorCode ierr; 132 PetscMPIInt *tagvalp=0,*maxval; 133 PetscTruth flg; 134 135 PetscFunctionBegin; 136 PetscValidIntPointer(tag,2); 137 138 if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) { 139 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);CHKERRQ(ierr); 140 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);CHKERRQ(ierr); 141 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);CHKERRQ(ierr); 142 } 143 144 ierr = MPI_Attr_get(comm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);CHKERRQ(ierr); 145 if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator"); 146 147 if (tagvalp[0] < 1) { 148 ierr = PetscLogInfo((0,"PetscCommGetNewTag:Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]));CHKERRQ(ierr); 149 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);CHKERRQ(ierr); 150 if (!flg) { 151 SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 152 } 153 tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 154 } 155 156 *tag = tagvalp[0]--; 157 PetscFunctionReturn(0); 158 } 159 160 #undef __FUNCT__ 161 #define __FUNCT__ "PetscCommDuplicate" 162 /*@C 163 PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc 164 communicator. 165 166 Collective on MPI_Comm 167 168 Input Parameters: 169 . comm_in - Input communicator 170 171 Output Parameters: 172 + comm_out - Output communicator. May be comm_in. 173 - first_tag - Tag available that has not already been used with this communicator (you may 174 pass in PETSC_NULL if you do not need a tag) 175 176 PETSc communicators are just regular MPI communicators that keep track of which 177 tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into 178 a PETSc creation routine it will be duplicated for use in the object. 179 180 Level: developer 181 182 Concepts: communicator^duplicate 183 184 .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag() 185 @*/ 186 PetscErrorCode PETSC_DLLEXPORT PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag) 187 { 188 PetscErrorCode ierr; 189 PetscMPIInt *tagvalp,*maxval; 190 PetscTruth flg; 191 192 PetscFunctionBegin; 193 if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) { 194 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);CHKERRQ(ierr); 195 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);CHKERRQ(ierr); 196 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);CHKERRQ(ierr); 197 } 198 ierr = MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);CHKERRQ(ierr); 199 200 if (!flg) { 201 void *ptr; 202 /* check if this communicator has a PETSc communicator imbedded in it */ 203 ierr = MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);CHKERRQ(ierr); 204 /* 205 We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers 206 */ 207 ierr = PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 208 if (!flg) { 209 /* This communicator is not yet known to this system, so we duplicate it and set its value */ 210 ierr = MPI_Comm_dup(comm_in,comm_out);CHKERRQ(ierr); 211 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);CHKERRQ(ierr); 212 if (!flg) { 213 SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 214 } 215 ierr = PetscMalloc(2*sizeof(PetscMPIInt),&tagvalp);CHKERRQ(ierr); 216 tagvalp[0] = *maxval; 217 tagvalp[1] = 0; 218 ierr = MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);CHKERRQ(ierr); 219 ierr = PetscLogInfo((0,"PetscCommDuplicate: Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval));CHKERRQ(ierr); 220 221 /* save PETSc communicator inside user communicator, so we can get it next time */ 222 ierr = PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));CHKERRQ(ierr); 223 ierr = MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);CHKERRQ(ierr); 224 ierr = PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));CHKERRQ(ierr); 225 ierr = MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);CHKERRQ(ierr); 226 } else { 227 ierr = MPI_Attr_get(*comm_out,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);CHKERRQ(ierr); 228 if (!flg) { 229 SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set"); 230 } 231 ierr = PetscLogInfo((0,"PetscCommDuplicate: Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out));CHKERRQ(ierr); 232 } 233 } else { 234 #if defined(PETSC_USE_DEBUG) 235 PetscMPIInt tag; 236 ierr = MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);CHKERRQ(ierr); 237 if (tag != tagvalp[0]) { 238 SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors."); 239 } 240 #endif 241 *comm_out = comm_in; 242 } 243 244 if (tagvalp[0] < 1) { 245 ierr = PetscLogInfo((0,"PetscCommDuplicate:Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]));CHKERRQ(ierr); 246 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);CHKERRQ(ierr); 247 if (!flg) { 248 SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 249 } 250 tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 251 } 252 253 if (first_tag) { 254 *first_tag = tagvalp[0]--; 255 } 256 tagvalp[1]++; /* number of references to this comm */ 257 PetscFunctionReturn(0); 258 } 259 260 #undef __FUNCT__ 261 #define __FUNCT__ "PetscCommDestroy" 262 /*@C 263 PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate(). 264 265 Collective on MPI_Comm 266 267 Input Parameter: 268 . comm - the communicator to free 269 270 Level: developer 271 272 Concepts: communicator^destroy 273 274 @*/ 275 PetscErrorCode PETSC_DLLEXPORT PetscCommDestroy(MPI_Comm *comm) 276 { 277 PetscErrorCode ierr; 278 PetscMPIInt *tagvalp; 279 PetscTruth flg; 280 MPI_Comm icomm = *comm,ocomm; 281 void *ptr; 282 283 PetscFunctionBegin; 284 if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) { 285 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);CHKERRQ(ierr); 286 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);CHKERRQ(ierr); 287 ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);CHKERRQ(ierr); 288 } 289 ierr = MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);CHKERRQ(ierr); 290 if (!flg) { 291 ierr = MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);CHKERRQ(ierr); 292 /* 293 We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers 294 */ 295 ierr = PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 296 if (!flg) { 297 PetscFunctionReturn(0); 298 } 299 ierr = MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);CHKERRQ(ierr); 300 if (!flg) { 301 SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory"); 302 } 303 } 304 tagvalp[1]--; 305 if (!tagvalp[1]) { 306 307 ierr = MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,(PetscMPIInt*)&flg);CHKERRQ(ierr); 308 ierr = PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 309 310 if (flg) { 311 ierr = MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);CHKERRQ(ierr); 312 } 313 314 ierr = PetscLogInfo((0,"PetscCommDestroy:Deleting MPI_Comm %ld\n",(long)icomm));CHKERRQ(ierr); 315 ierr = MPI_Comm_free(&icomm);CHKERRQ(ierr); 316 } 317 PetscFunctionReturn(0); 318 } 319 320