Actual source code: zts.c
2: #include src/fortran/custom/zpetsc.h
3: #include petscts.h
5: #ifdef PETSC_HAVE_FORTRAN_CAPS
6: #define tssetproblemtype_ TSSETPROBLEMTYPE
7: #define tssetrhsfunction_ TSSETRHSFUNCTION
8: #define tssetrhsmatrix_ TSSETRHSMATRIX
9: #define tssetrhsjacobian_ TSSETRHSJACOBIAN
10: #define tscreate_ TSCREATE
11: #define tsgetsolution_ TSGETSOLUTION
12: #define tsgetsnes_ TSGETSNES
13: #define tsgetksp_ TSGETKSP
14: #define tsgettype_ TSGETTYPE
15: #define tsdestroy_ TSDESTROY
16: #define tssetmonitor_ TSSETMONITOR
17: #define tssettype_ TSSETTYPE
18: #define tspvodegetiterations_ TSPVODEGETITERATIONS
19: #define tsdefaultcomputejacobian_ TSDEFAULTCOMPUTEJACOBIAN
20: #define tsdefaultcomputejacobiancolor_ TSDEFAULTCOMPUTEJACOBIANCOLOR
21: #define tsgetoptionsprefix_ TSGETOPTIONSPREFIX
22: #define tsdefaultmonitor_ TSDEFAULTMONITOR
23: #define tsview_ TSVIEW
24: #define tsgetrhsjacobian_ TSGETRHSJACOBIAN
25: #define tsgetrhsmatrix_ TSGETRHSMATRIX
26: #define tssetrhsboundaryconditions_ TSSETRHSBOUNDARYCONDITIONS
27: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
28: #define tssetproblemtype_ tssetproblemtype
29: #define tsdefaultcomputejacobian_ tsdefaultcomputejacobian
30: #define tsdefaultcomputejacobiancolor_ tsdefaultcomputejacobiancolor
31: #define tspvodegetiterations_ tspvodegetiterations
32: #define tssetrhsfunction_ tssetrhsfunction
33: #define tssetrhsmatrix_ tssetrhsmatrix
34: #define tssetrhsjacobian_ tssetrhsjacobian
35: #define tscreate_ tscreate
36: #define tsgetsolution_ tsgetsolution
37: #define tsgetsnes_ tsgetsnes
38: #define tsgetksp_ tsgetksp
39: #define tsgettype_ tsgettype
40: #define tsdestroy_ tsdestroy
41: #define tssetmonitor_ tssetmonitor
42: #define tssettype_ tssettype
43: #define tsgetoptionsprefix_ tsgetoptionsprefix
44: #define tsdefaultmonitor_ tsdefaultmonitor
45: #define tsview_ tsview
46: #define tsgetrhsjacobian_ tsgetrhsjacobian
47: #define tsgetrhsmatrix_ tsgetrhsmatrix
48: #define tssetrhsboundaryconditions_ tssetrhsboundaryconditions
49: #endif
52: static PetscErrorCode ourtsbcfunction(TS ts,PetscReal d,Vec x,void *ctx)
53: {
54: PetscErrorCode 0;
55: (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[0]))(&ts,&d,&x,ctx,&ierr);
56: return 0;
57: }
59: static PetscErrorCode ourtsfunction(TS ts,PetscReal d,Vec x,Vec f,void *ctx)
60: {
61: PetscErrorCode 0;
62: (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[1]))(&ts,&d,&x,&f,ctx,&ierr);
63: return 0;
64: }
66: static PetscErrorCode ourtsmatrix(TS ts,PetscReal d,Mat* m,Mat* p,MatStructure* type,void*ctx)
67: {
68: PetscErrorCode 0;
69: (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[2]))(&ts,&d,m,p,type,ctx,&ierr);
70: return 0;
71: }
73: static PetscErrorCode ourtsjacobian(TS ts,PetscReal d,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx)
74: {
75: PetscErrorCode 0;
76: (*(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);
77: return 0;
78: }
80: /*
81: Note ctx is the same as ts so we need to get the Fortran context out of the TS
82: */
83: static PetscErrorCode ourtsmonitor(TS ts,PetscInt i,PetscReal d,Vec v,void*ctx)
84: {
85: PetscErrorCode 0;
86: void (*mctx)(void) = ((PetscObject)ts)->fortran_func_pointers[6];
87: (*(void (PETSC_STDCALL *)(TS*,PetscInt*,PetscReal*,Vec*,FCNVOID,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[4]))(&ts,&i,&d,&v,mctx,&ierr);
88: return 0;
89: }
91: static PetscErrorCode ourtsdestroy(void *ctx)
92: {
93: PetscErrorCode 0;
94: TS ts = (TS)ctx;
95: void (*mctx)(void) = ((PetscObject)ts)->fortran_func_pointers[6];
96: (*(void (PETSC_STDCALL *)(FCNVOID,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[5]))(mctx,&ierr);
97: return 0;
98: }
102: void PETSC_STDCALL tssetrhsboundaryconditions_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
103: {
104: ((PetscObject)*ts)->fortran_func_pointers[0] = (FCNVOID)f;
105: *TSSetRHSBoundaryConditions(*ts,ourtsbcfunction,ctx);
106: }
108: void PETSC_STDCALL tsgetrhsjacobian_(TS *ts,Mat *J,Mat *M,void **ctx,PetscErrorCode *ierr)
109: {
110: *TSGetRHSJacobian(*ts,J,M,ctx);
111: }
113: void PETSC_STDCALL tssetproblemtype_(TS *ts,TSProblemType *t,PetscErrorCode *ierr)
114: {
115: *TSSetProblemType(*ts,*t);
116: }
118: void PETSC_STDCALL tsgetrhsmatrix_(TS *ts,Mat *J,Mat *M,void **ctx,PetscErrorCode *ierr)
119: {
120: *TSGetRHSMatrix(*ts,J,M,ctx);
121: }
123: void PETSC_STDCALL tsview_(TS *ts,PetscViewer *viewer, PetscErrorCode *ierr)
124: {
125: PetscViewer v;
126: PetscPatchDefaultViewers_Fortran(viewer,v);
127: *TSView(*ts,v);
128: }
130: /* function */
131: void tsdefaultcomputejacobian_(TS *ts,PetscReal *t,Vec *xx1,Mat *J,Mat *B,MatStructure *flag,void *ctx,PetscErrorCode *ierr)
132: {
133: *TSDefaultComputeJacobian(*ts,*t,*xx1,J,B,flag,ctx);
134: }
136: /* function */
137: void tsdefaultcomputejacobiancolor_(TS *ts,PetscReal *t,Vec *xx1,Mat *J,Mat *B,MatStructure *flag,void *ctx,PetscErrorCode *ierr)
138: {
139: *TSDefaultComputeJacobianColor(*ts,*t,*xx1,J,B,flag,*(MatFDColoring*)ctx);
140: }
142: void PETSC_STDCALL tssettype_(TS *ts,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
143: {
144: char *t;
146: FIXCHAR(type,len,t);
147: *TSSetType(*ts,t);
148: FREECHAR(type,t);
149: }
152: void PETSC_STDCALL tssetrhsfunction_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr)
153: {
154: ((PetscObject)*ts)->fortran_func_pointers[1] = (FCNVOID)f;
155: *TSSetRHSFunction(*ts,ourtsfunction,fP);
156: }
159: /* ---------------------------------------------------------*/
161: void PETSC_STDCALL tssetrhsmatrix_(TS *ts,Mat *A,Mat *B,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Mat*,Mat*,MatStructure*,
162: void*,PetscInt *),void*fP,PetscErrorCode *ierr)
163: {
164: if (FORTRANNULLFUNCTION(f)) {
165: *TSSetRHSMatrix(*ts,*A,*B,PETSC_NULL,fP);
166: } else {
167: ((PetscObject)*ts)->fortran_func_pointers[2] = (FCNVOID)f;
168: *TSSetRHSMatrix(*ts,*A,*B,ourtsmatrix,fP);
169: }
170: }
172: /* ---------------------------------------------------------*/
174: void PETSC_STDCALL tssetrhsjacobian_(TS *ts,Mat *A,Mat *B,void (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,
175: void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr)
176: {
177: if (FORTRANNULLFUNCTION(f)) {
178: *TSSetRHSJacobian(*ts,*A,*B,PETSC_NULL,fP);
179: } else if ((FCNVOID)f == (FCNVOID)tsdefaultcomputejacobian_) {
180: *TSSetRHSJacobian(*ts,*A,*B,TSDefaultComputeJacobian,fP);
181: } else if ((FCNVOID)f == (FCNVOID)tsdefaultcomputejacobiancolor_) {
182: *TSSetRHSJacobian(*ts,*A,*B,TSDefaultComputeJacobianColor,*(MatFDColoring*)fP);
183: } else {
184: ((PetscObject)*ts)->fortran_func_pointers[3] = (FCNVOID)f;
185: *TSSetRHSJacobian(*ts,*A,*B,ourtsjacobian,fP);
186: }
187: }
189: void PETSC_STDCALL tsgetsolution_(TS *ts,Vec *v,PetscErrorCode *ierr)
190: {
191: *TSGetSolution(*ts,v);
192: }
194: void PETSC_STDCALL tscreate_(MPI_Comm *comm,TS *outts,PetscErrorCode *ierr)
195: {
196: *TSCreate((MPI_Comm)PetscToPointerComm(*comm),outts);
197: *PetscMalloc(7*sizeof(void*),&((PetscObject)*outts)->fortran_func_pointers);
198: }
200: void PETSC_STDCALL tsgetsnes_(TS *ts,SNES *snes,PetscErrorCode *ierr)
201: {
202: *TSGetSNES(*ts,snes);
203: }
205: void PETSC_STDCALL tsgetksp_(TS *ts,KSP *ksp,PetscErrorCode *ierr)
206: {
207: *TSGetKSP(*ts,ksp);
208: }
210: void PETSC_STDCALL tsgettype_(TS *ts,CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
211: {
212: char *tname;
214: *TSGetType(*ts,(TSType *)&tname);
215: #if defined(PETSC_USES_CPTOFCD)
216: {
217: char *t = _fcdtocp(name); int len1 = _fcdlen(name);
218: *PetscStrncpy(t,tname,len1);
219: }
220: #else
221: *PetscStrncpy(name,tname,len);
222: #endif
223: FIXRETURNCHAR(name,len);
224: }
226: #if defined(PETSC_HAVE_PVODE)
227: void PETSC_STDCALL tspvodegetiterations_(TS *ts,PetscInt *nonlin,PetscInt *lin,PetscErrorCode *ierr)
228: {
229: CHKFORTRANNULLINTEGER(nonlin);
230: CHKFORTRANNULLINTEGER(lin);
231: *TSPVodeGetIterations(*ts,nonlin,lin);
232: }
233: #endif
235: void PETSC_STDCALL tsdestroy_(TS *ts,PetscErrorCode *ierr){
236: *TSDestroy(*ts);
237: }
239: void PETSC_STDCALL tsdefaultmonitor_(TS *ts,PetscInt *step,PetscReal *dt,Vec *x,void *ctx,PetscErrorCode *ierr)
240: {
241: *TSDefaultMonitor(*ts,*step,*dt,*x,ctx);
242: }
245: 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)
246: {
247: if ((FCNVOID)func == (FCNVOID)tsdefaultmonitor_) {
248: *TSSetMonitor(*ts,TSDefaultMonitor,0,0);
249: } else {
250: ((PetscObject)*ts)->fortran_func_pointers[4] = (FCNVOID)func;
251: ((PetscObject)*ts)->fortran_func_pointers[5] = (FCNVOID)d;
252: ((PetscObject)*ts)->fortran_func_pointers[6] = (FCNVOID)mctx;
253: if (FORTRANNULLFUNCTION(d)) {
254: *TSSetMonitor(*ts,ourtsmonitor,*ts,0);
255: } else {
256: *TSSetMonitor(*ts,ourtsmonitor,*ts,ourtsdestroy);
257: }
258: }
259: }
261: void PETSC_STDCALL tsgetoptionsprefix_(TS *ts,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
262: {
263: const char *tname;
265: *TSGetOptionsPrefix(*ts,&tname);
266: #if defined(PETSC_USES_CPTOFCD)
267: {
268: char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
269: *PetscStrncpy(t,tname,len1);
270: }
271: #else
272: *PetscStrncpy(prefix,tname,len);
273: #endif
274: }