1 #include <petsc-private/fortranimpl.h> 2 #include <petscdmshell.h> /*I "petscdmshell.h" I*/ 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define dmshellsetcreatematrix_ DMSHELLSETCREATEMATRIX 6 #define dmshellsetcreateglobalvector_ DMSHELLSETCREATEGLOBALVECTOR_ 7 #define dmshellsetcreatelocalvector_ DMSHELLSETCREATELOCALVECTOR_ 8 #define dmshellsetglobaltolocal_ DMSHELLSETGLOBALTOLOCAL_ 9 #define dmshellsetlocaltoglobal_ DMSHELLSETLOCALTOGLOBAL_ 10 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 11 #define dmshellsetcreatematrix_ dmshellsetcreatematrix 12 #define dmshellsetcreateglobalvector_ dmshellsetcreateglobalvector 13 #define dmshellsetcreatelocalvector_ dmshellsetcreatelocalvector 14 #define dmshellsetglobaltolocal_ dmshellsetglobaltolocal 15 #define dmshellsetlocaltoglobal_ dmshellsetlocaltoglobal 16 #endif 17 18 /* 19 * C routines are required for matrix and global vector creation. We define C routines here that call the corresponding 20 * Fortran routine (indexed by _cb) that was set by the user. 21 */ 22 23 static struct { 24 PetscFortranCallbackId creatematrix; 25 PetscFortranCallbackId createglobalvector; 26 PetscFortranCallbackId createlocalvector; 27 PetscFortranCallbackId globaltolocalbegin; 28 PetscFortranCallbackId globaltolocalend; 29 PetscFortranCallbackId localtoglobalbegin; 30 PetscFortranCallbackId localtoglobalend; 31 } _cb; 32 33 #undef __FUNCT__ 34 #define __FUNCT__ "ourcreatematrix" 35 static PetscErrorCode ourcreatematrix(DM dm,MatType type,Mat *A) 36 { 37 int len; 38 char *ftype = (char*)type; 39 if (type) { 40 size_t slen; 41 PetscStrlen(type,&slen); 42 len = (int)slen; 43 } else { 44 type = PETSC_NULL_CHARACTER_Fortran; 45 len = 0; 46 } 47 PetscObjectUseFortranCallbackSubType(dm,_cb.creatematrix,(DM*,CHAR PETSC_MIXED_LEN_PROTO,Mat*,PetscErrorCode* PETSC_END_LEN_PROTO), 48 (&dm,ftype PETSC_MIXED_LEN_CALL(len),A,&ierr PETSC_END_LEN_CALL(len))); 49 return 0; 50 } 51 52 #undef __FUNCT__ 53 #define __FUNCT__ "ourcreateglobalvector" 54 static PetscErrorCode ourcreateglobalvector(DM dm,Vec *v) 55 { 56 PetscObjectUseFortranCallbackSubType(dm,_cb.createglobalvector,(DM*,Vec*,PetscErrorCode*),(&dm,v,&ierr)); 57 return 0; 58 } 59 60 #undef __FUNCT__ 61 #define __FUNCT__ "ourcreatelocalvector" 62 static PetscErrorCode ourcreatelocalvector(DM dm,Vec *v) 63 { 64 PetscObjectUseFortranCallbackSubType(dm,_cb.createlocalvector,(DM*,Vec*,PetscErrorCode*),(&dm,v,&ierr)); 65 return 0; 66 } 67 68 #undef __FUNCT__ 69 #define __FUNCT__ "ourglobaltolocalbegin" 70 static PetscErrorCode ourglobaltolocalbegin(DM dm,Vec g,InsertMode mode,Vec l) 71 { 72 PetscObjectUseFortranCallbackSubType(dm,_cb.globaltolocalbegin,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&g,&mode,&l,&ierr)); 73 return 0; 74 } 75 76 #undef __FUNCT__ 77 #define __FUNCT__ "ourglobaltolocalend" 78 static PetscErrorCode ourglobaltolocalend(DM dm,Vec g,InsertMode mode,Vec l) 79 { 80 PetscObjectUseFortranCallbackSubType(dm,_cb.globaltolocalend,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&g,&mode,&l,&ierr)); 81 return 0; 82 } 83 84 #undef __FUNCT__ 85 #define __FUNCT__ "ourlocaltoglobalbegin" 86 static PetscErrorCode ourlocaltoglobalbegin(DM dm,Vec l,InsertMode mode,Vec g) 87 { 88 PetscObjectUseFortranCallbackSubType(dm,_cb.localtoglobalbegin,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&l,&mode,&g,&ierr)); 89 return 0; 90 } 91 92 #undef __FUNCT__ 93 #define __FUNCT__ "ourlocaltoglobalend" 94 static PetscErrorCode ourlocaltoglobalend(DM dm,Vec l,InsertMode mode,Vec g) 95 { 96 PetscObjectUseFortranCallbackSubType(dm,_cb.localtoglobalend,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&l,&mode,&g,&ierr)); 97 return 0; 98 } 99 100 PETSC_EXTERN void PETSC_STDCALL dmshellsetcreatematrix_(DM *dm,void (PETSC_STDCALL *func)(DM*,CHAR type PETSC_MIXED_LEN(len),Mat*,PetscErrorCode* PETSC_END_LEN(len)),PetscErrorCode *ierr) 101 { 102 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.creatematrix,(PetscVoidFunction)func,NULL); 103 if (*ierr) return; 104 *ierr = DMShellSetCreateMatrix(*dm,ourcreatematrix); 105 } 106 107 PETSC_EXTERN void PETSC_STDCALL dmshellsetcreateglobalvector_(DM *dm,void (PETSC_STDCALL *func)(DM*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 108 { 109 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.createglobalvector,(PetscVoidFunction)func,NULL); 110 if (*ierr) return; 111 *ierr = DMShellSetCreateGlobalVector(*dm,ourcreateglobalvector); 112 } 113 114 PETSC_EXTERN void PETSC_STDCALL dmshellsetcreatelocalvector_(DM *dm,void (PETSC_STDCALL *func)(DM*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 115 { 116 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.createlocalvector,(PetscVoidFunction)func,NULL); 117 if (*ierr) return; 118 *ierr = DMShellSetCreateLocalVector(*dm,ourcreatelocalvector); 119 } 120 121 PETSC_EXTERN void PETSC_STDCALL dmshellsetglobaltolocal_(DM *dm,void (PETSC_STDCALL *begin)(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),void (PETSC_STDCALL *end)(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 122 { 123 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.globaltolocalbegin,(PetscVoidFunction)begin,NULL); 124 if (*ierr) return; 125 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.globaltolocalend,(PetscVoidFunction)end,NULL); 126 if (*ierr) return; 127 *ierr = DMShellSetGlobalToLocal(*dm,ourglobaltolocalbegin,ourglobaltolocalend); 128 } 129 130 PETSC_EXTERN void PETSC_STDCALL dmshellsetlocaltoglobal_(DM *dm,void (PETSC_STDCALL *begin)(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),void (PETSC_STDCALL *end)(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 131 { 132 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.localtoglobalbegin,(PetscVoidFunction)begin,NULL); 133 if (*ierr) return; 134 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.localtoglobalend,(PetscVoidFunction)end,NULL); 135 if (*ierr) return; 136 *ierr = DMShellSetLocalToGlobal(*dm,ourlocaltoglobalbegin,ourlocaltoglobalend); 137 } 138