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 #define dmshellsetlocaltolocal_ DMSHELLSETLOCALTOLOCAL_ 11 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 12 #define dmshellsetcreatematrix_ dmshellsetcreatematrix 13 #define dmshellsetcreateglobalvector_ dmshellsetcreateglobalvector 14 #define dmshellsetcreatelocalvector_ dmshellsetcreatelocalvector 15 #define dmshellsetglobaltolocal_ dmshellsetglobaltolocal 16 #define dmshellsetlocaltoglobal_ dmshellsetlocaltoglobal 17 #define dmshellsetlocaltolocal_ dmshellsetlocaltolocal_ 18 #endif 19 20 /* 21 * C routines are required for matrix and global vector creation. We define C routines here that call the corresponding 22 * Fortran routine (indexed by _cb) that was set by the user. 23 */ 24 25 static struct { 26 PetscFortranCallbackId creatematrix; 27 PetscFortranCallbackId createglobalvector; 28 PetscFortranCallbackId createlocalvector; 29 PetscFortranCallbackId globaltolocalbegin; 30 PetscFortranCallbackId globaltolocalend; 31 PetscFortranCallbackId localtoglobalbegin; 32 PetscFortranCallbackId localtoglobalend; 33 PetscFortranCallbackId localtolocalbegin; 34 PetscFortranCallbackId localtolocalend; 35 } _cb; 36 37 #undef __FUNCT__ 38 #define __FUNCT__ "ourcreatematrix" 39 static PetscErrorCode ourcreatematrix(DM dm,MatType type,Mat *A) 40 { 41 int len; 42 char *ftype = (char*)type; 43 if (type) { 44 size_t slen; 45 PetscStrlen(type,&slen); 46 len = (int)slen; 47 } else { 48 type = PETSC_NULL_CHARACTER_Fortran; 49 len = 0; 50 } 51 PetscObjectUseFortranCallbackSubType(dm,_cb.creatematrix,(DM*,CHAR PETSC_MIXED_LEN_PROTO,Mat*,PetscErrorCode* PETSC_END_LEN_PROTO), 52 (&dm,ftype PETSC_MIXED_LEN_CALL(len),A,&ierr PETSC_END_LEN_CALL(len))); 53 return 0; 54 } 55 56 #undef __FUNCT__ 57 #define __FUNCT__ "ourcreateglobalvector" 58 static PetscErrorCode ourcreateglobalvector(DM dm,Vec *v) 59 { 60 PetscObjectUseFortranCallbackSubType(dm,_cb.createglobalvector,(DM*,Vec*,PetscErrorCode*),(&dm,v,&ierr)); 61 return 0; 62 } 63 64 #undef __FUNCT__ 65 #define __FUNCT__ "ourcreatelocalvector" 66 static PetscErrorCode ourcreatelocalvector(DM dm,Vec *v) 67 { 68 PetscObjectUseFortranCallbackSubType(dm,_cb.createlocalvector,(DM*,Vec*,PetscErrorCode*),(&dm,v,&ierr)); 69 return 0; 70 } 71 72 #undef __FUNCT__ 73 #define __FUNCT__ "ourglobaltolocalbegin" 74 static PetscErrorCode ourglobaltolocalbegin(DM dm,Vec g,InsertMode mode,Vec l) 75 { 76 PetscObjectUseFortranCallbackSubType(dm,_cb.globaltolocalbegin,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&g,&mode,&l,&ierr)); 77 return 0; 78 } 79 80 #undef __FUNCT__ 81 #define __FUNCT__ "ourglobaltolocalend" 82 static PetscErrorCode ourglobaltolocalend(DM dm,Vec g,InsertMode mode,Vec l) 83 { 84 PetscObjectUseFortranCallbackSubType(dm,_cb.globaltolocalend,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&g,&mode,&l,&ierr)); 85 return 0; 86 } 87 88 #undef __FUNCT__ 89 #define __FUNCT__ "ourlocaltoglobalbegin" 90 static PetscErrorCode ourlocaltoglobalbegin(DM dm,Vec l,InsertMode mode,Vec g) 91 { 92 PetscObjectUseFortranCallbackSubType(dm,_cb.localtoglobalbegin,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&l,&mode,&g,&ierr)); 93 return 0; 94 } 95 96 #undef __FUNCT__ 97 #define __FUNCT__ "ourlocaltoglobalend" 98 static PetscErrorCode ourlocaltoglobalend(DM dm,Vec l,InsertMode mode,Vec g) 99 { 100 PetscObjectUseFortranCallbackSubType(dm,_cb.localtoglobalend,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&l,&mode,&g,&ierr)); 101 return 0; 102 } 103 104 #undef __FUNCT__ 105 #define __FUNCT__ "ourlocaltolocalbegin" 106 static PetscErrorCode ourlocaltolocalbegin(DM dm,Vec g,InsertMode mode,Vec l) 107 { 108 PetscObjectUseFortranCallbackSubType(dm,_cb.localtolocalbegin,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&g,&mode,&l,&ierr)); 109 return 0; 110 } 111 112 #undef __FUNCT__ 113 #define __FUNCT__ "ourlocaltolocalend" 114 static PetscErrorCode ourlocaltolocalend(DM dm,Vec g,InsertMode mode,Vec l) 115 { 116 PetscObjectUseFortranCallbackSubType(dm,_cb.localtolocalend,(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),(&dm,&g,&mode,&l,&ierr)); 117 return 0; 118 } 119 120 121 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) 122 { 123 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.creatematrix,(PetscVoidFunction)func,NULL); 124 if (*ierr) return; 125 *ierr = DMShellSetCreateMatrix(*dm,ourcreatematrix); 126 } 127 128 PETSC_EXTERN void PETSC_STDCALL dmshellsetcreateglobalvector_(DM *dm,void (PETSC_STDCALL *func)(DM*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 129 { 130 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.createglobalvector,(PetscVoidFunction)func,NULL); 131 if (*ierr) return; 132 *ierr = DMShellSetCreateGlobalVector(*dm,ourcreateglobalvector); 133 } 134 135 PETSC_EXTERN void PETSC_STDCALL dmshellsetcreatelocalvector_(DM *dm,void (PETSC_STDCALL *func)(DM*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 136 { 137 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.createlocalvector,(PetscVoidFunction)func,NULL); 138 if (*ierr) return; 139 *ierr = DMShellSetCreateLocalVector(*dm,ourcreatelocalvector); 140 } 141 142 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) 143 { 144 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.globaltolocalbegin,(PetscVoidFunction)begin,NULL); 145 if (*ierr) return; 146 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.globaltolocalend,(PetscVoidFunction)end,NULL); 147 if (*ierr) return; 148 *ierr = DMShellSetGlobalToLocal(*dm,ourglobaltolocalbegin,ourglobaltolocalend); 149 } 150 151 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) 152 { 153 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.localtoglobalbegin,(PetscVoidFunction)begin,NULL); 154 if (*ierr) return; 155 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.localtoglobalend,(PetscVoidFunction)end,NULL); 156 if (*ierr) return; 157 *ierr = DMShellSetLocalToGlobal(*dm,ourlocaltoglobalbegin,ourlocaltoglobalend); 158 } 159 160 PETSC_EXTERN void PETSC_STDCALL dmshellsetlocaltolocal_(DM *dm,void (PETSC_STDCALL *begin)(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),void (PETSC_STDCALL *end)(DM*,Vec*,InsertMode*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 161 { 162 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.localtolocalbegin,(PetscVoidFunction)begin,NULL); 163 if (*ierr) return; 164 *ierr = PetscObjectSetFortranCallback((PetscObject)*dm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.localtolocalend,(PetscVoidFunction)end,NULL); 165 if (*ierr) return; 166 *ierr = DMShellSetLocalToLocal(*dm,ourlocaltolocalbegin,ourlocaltolocalend); 167 } 168