1 #include "zpetsc.h" 2 #include "petscts.h" 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define tssetrhsboundaryconditions_ TSSETRHSBOUNDARYCONDITIONS 6 #define tssetrhsfunction_ TSSETRHSFUNCTION 7 #define tssetrhsmatrix_ TSSETRHSMATRIX 8 #define tssetrhsjacobian_ TSSETRHSJACOBIAN 9 #define tsgetrhsjacobian_ TSGETRHSJACOBIAN 10 #define tsgetrhsmatrix_ TSGETRHSMATRIX 11 #define tsview_ TSVIEW 12 #define tsgetoptionsprefix_ TSGETOPTIONSPREFIX 13 #define tssetmonitor_ TSSETMONITOR 14 #define tsdefaultcomputejacobian_ TSDEFAULTCOMPUTEJACOBIAN 15 #define tsdefaultcomputejacobiancolor_ TSDEFAULTCOMPUTEJACOBIANCOLOR 16 #define tsdefaultmonitor_ TSDEFAULTMONITOR 17 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 18 #define tssetrhsboundaryconditions_ tssetrhsboundaryconditions 19 #define tssetrhsfunction_ tssetrhsfunction 20 #define tssetrhsmatrix_ tssetrhsmatrix 21 #define tssetrhsjacobian_ tssetrhsjacobian 22 #define tsgetrhsjacobian_ tsgetrhsjacobian 23 #define tsgetrhsmatrix_ tsgetrhsmatrix 24 #define tsview_ tsview 25 #define tsgetoptionsprefix_ tsgetoptionsprefix 26 #define tssetmonitor_ tssetmonitor 27 #define tsdefaultcomputejacobian_ tsdefaultcomputejacobian 28 #define tsdefaultcomputejacobiancolor_ tsdefaultcomputejacobiancolor 29 #define tsdefaultmonitor_ tsdefaultmonitor 30 #endif 31 32 static PetscErrorCode ourtsbcfunction(TS ts,PetscReal d,Vec x,void *ctx) 33 { 34 PetscErrorCode ierr = 0; 35 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[0]))(&ts,&d,&x,ctx,&ierr); 36 return 0; 37 } 38 static PetscErrorCode ourtsfunction(TS ts,PetscReal d,Vec x,Vec f,void *ctx) 39 { 40 PetscErrorCode ierr = 0; 41 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[1]))(&ts,&d,&x,&f,ctx,&ierr); 42 return 0; 43 } 44 static PetscErrorCode ourtsmatrix(TS ts,PetscReal d,Mat* m,Mat* p,MatStructure* type,void*ctx) 45 { 46 PetscErrorCode ierr = 0; 47 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[2]))(&ts,&d,m,p,type,ctx,&ierr); 48 return 0; 49 } 50 static PetscErrorCode ourtsjacobian(TS ts,PetscReal d,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx) 51 { 52 PetscErrorCode ierr = 0; 53 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[3]))(&ts,&d,&x,m,p,type,ctx,&ierr); 54 return 0; 55 } 56 57 static PetscErrorCode ourtsdestroy(void *ctx) 58 { 59 PetscErrorCode ierr = 0; 60 TS ts = (TS)ctx; 61 void (*mctx)(void) = ((PetscObject)ts)->fortran_func_pointers[6]; 62 (*(void (PETSC_STDCALL *)(FCNVOID,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[5]))(mctx,&ierr); 63 return 0; 64 } 65 66 /* 67 Note ctx is the same as ts so we need to get the Fortran context out of the TS 68 */ 69 static PetscErrorCode ourtsmonitor(TS ts,PetscInt i,PetscReal d,Vec v,void*ctx) 70 { 71 PetscErrorCode ierr = 0; 72 void (*mctx)(void) = ((PetscObject)ts)->fortran_func_pointers[6]; 73 (*(void (PETSC_STDCALL *)(TS*,PetscInt*,PetscReal*,Vec*,FCNVOID,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[4]))(&ts,&i,&d,&v,mctx,&ierr); 74 return 0; 75 } 76 77 EXTERN_C_BEGIN 78 79 80 void PETSC_STDCALL tssetrhsboundaryconditions_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 81 { 82 ((PetscObject)*ts)->fortran_func_pointers[0] = (FCNVOID)f; 83 *ierr = TSSetRHSBoundaryConditions(*ts,ourtsbcfunction,ctx); 84 } 85 86 void PETSC_STDCALL tssetrhsfunction_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 87 { 88 ((PetscObject)*ts)->fortran_func_pointers[1] = (FCNVOID)f; 89 *ierr = TSSetRHSFunction(*ts,ourtsfunction,fP); 90 } 91 92 void PETSC_STDCALL tssetrhsmatrix_(TS *ts,Mat *A,Mat *B,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Mat*,Mat*,MatStructure*, 93 void*,PetscInt *),void*fP,PetscErrorCode *ierr) 94 { 95 if (FORTRANNULLFUNCTION(f)) { 96 *ierr = TSSetRHSMatrix(*ts,*A,*B,PETSC_NULL,fP); 97 } else { 98 ((PetscObject)*ts)->fortran_func_pointers[2] = (FCNVOID)f; 99 *ierr = TSSetRHSMatrix(*ts,*A,*B,ourtsmatrix,fP); 100 } 101 } 102 103 /* ---------------------------------------------------------*/ 104 extern void tsdefaultcomputejacobian_(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*); 105 extern void tsdefaultcomputejacobiancolor_(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*); 106 107 void PETSC_STDCALL tssetrhsjacobian_(TS *ts,Mat *A,Mat *B,void (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*, 108 void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 109 { 110 if (FORTRANNULLFUNCTION(f)) { 111 *ierr = TSSetRHSJacobian(*ts,*A,*B,PETSC_NULL,fP); 112 } else if ((FCNVOID)f == (FCNVOID)tsdefaultcomputejacobian_) { 113 *ierr = TSSetRHSJacobian(*ts,*A,*B,TSDefaultComputeJacobian,fP); 114 } else if ((FCNVOID)f == (FCNVOID)tsdefaultcomputejacobiancolor_) { 115 *ierr = TSSetRHSJacobian(*ts,*A,*B,TSDefaultComputeJacobianColor,*(MatFDColoring*)fP); 116 } else { 117 ((PetscObject)*ts)->fortran_func_pointers[3] = (FCNVOID)f; 118 *ierr = TSSetRHSJacobian(*ts,*A,*B,ourtsjacobian,fP); 119 } 120 } 121 122 /* ---------------------------------------------------------*/ 123 124 extern void PETSC_STDCALL tsdefaultmonitor_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); 125 126 void PETSC_STDCALL tssetmonitor_(TS *ts,void (PETSC_STDCALL *func)(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*),void (*mctx)(void),void (PETSC_STDCALL *d)(void*,PetscErrorCode*),PetscErrorCode *ierr) 127 { 128 if ((FCNVOID)func == (FCNVOID)tsdefaultmonitor_) { 129 *ierr = TSSetMonitor(*ts,TSDefaultMonitor,0,0); 130 } else { 131 ((PetscObject)*ts)->fortran_func_pointers[4] = (FCNVOID)func; 132 ((PetscObject)*ts)->fortran_func_pointers[5] = (FCNVOID)d; 133 ((PetscObject)*ts)->fortran_func_pointers[6] = (FCNVOID)mctx; 134 if (FORTRANNULLFUNCTION(d)) { 135 *ierr = TSSetMonitor(*ts,ourtsmonitor,*ts,0); 136 } else { 137 *ierr = TSSetMonitor(*ts,ourtsmonitor,*ts,ourtsdestroy); 138 } 139 } 140 } 141 142 /* ---------------------------------------------------------*/ 143 void PETSC_STDCALL tsgetrhsjacobian_(TS *ts,Mat *J,Mat *M,void **ctx,PetscErrorCode *ierr) 144 { 145 *ierr = TSGetRHSJacobian(*ts,J,M,ctx); 146 } 147 148 void PETSC_STDCALL tsgetrhsmatrix_(TS *ts,Mat *J,Mat *M,void **ctx,PetscErrorCode *ierr) 149 { 150 *ierr = TSGetRHSMatrix(*ts,J,M,ctx); 151 } 152 153 void PETSC_STDCALL tsview_(TS *ts,PetscViewer *viewer, PetscErrorCode *ierr) 154 { 155 PetscViewer v; 156 PetscPatchDefaultViewers_Fortran(viewer,v); 157 *ierr = TSView(*ts,v); 158 } 159 160 void PETSC_STDCALL tsgetoptionsprefix_(TS *ts,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 161 { 162 const char *tname; 163 164 *ierr = TSGetOptionsPrefix(*ts,&tname); 165 #if defined(PETSC_USES_CPTOFCD) 166 { 167 char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix); 168 *ierr = PetscStrncpy(t,tname,len1); 169 } 170 #else 171 *ierr = PetscStrncpy(prefix,tname,len); 172 #endif 173 } 174 175 176 EXTERN_C_END 177