Actual source code: zpc.c
2: #include src/fortran/custom/zpetsc.h
3: #include petscksp.h
4: #include petscmg.h
6: #ifdef PETSC_HAVE_FORTRAN_CAPS
7: #define pcmgdefaultresidual_ PCMGDEFAULTRESIDUAL
8: #define pcmgsetresidual_ PCMGSETRESIDUAL
9: #define pcasmsetlocalsubdomains_ PCASMSETLOCALSUBDOMAINS
10: #define pcasmsetglobalsubdomains_ PCASMSETGLOBALSUBDOMAINS
11: #define pcasmgetlocalsubmatrices_ PCASMGETLOCALSUBMATRICES
12: #define pcasmgetlocalsubdomains_ PCASMGETLOCALSUBDOMAINS
13: #define pcregisterdestroy_ PCREGISTERDESTROY
14: #define pcdestroy_ PCDESTROY
15: #define pccreate_ PCCREATE
16: #define pcgetoperators_ PCGETOPERATORS
17: #define pcgetfactoredmatrix_ PCGETFACTOREDMATRIX
18: #define pcsetoptionsprefix_ PCSETOPTIONSPREFIX
19: #define pcappendoptionsprefix_ PCAPPENDOPTIONSPREFIX
20: #define pcbjacobigetsubksp_ PCBJACOBIGETSUBKSP
21: #define pcasmgetsubksp_ PCASMGETSUBKSP
22: #define pcmggetcoarsesolve_ PCMGGETCOARSESOLVE
23: #define pcmggetsmoother_ PCMGGETSMOOTHER
24: #define pcmggetsmootherup_ PCMGGETSMOOTHERUP
25: #define pcmggetsmootherdown_ PCMGGETSMOOTHERDOWN
26: #define pcshellsetapply_ PCSHELLSETAPPLY
27: #define pcshellsetapplytranspose_ PCSHELLSETAPPLYTRANSPOSE
28: #define pcshellsetapplyrichardson_ PCSHELLSETAPPLYRICHARDSON
29: #define pcgettype_ PCGETTYPE
30: #define pcsettype_ PCSETTYPE
31: #define pcgetoptionsprefix_ PCGETOPTIONSPREFIX
32: #define matnullspacecreate_ MATNULLSPACECREATE
33: #define pcview_ PCVIEW
34: #define pcmgsetlevels_ PCMGSETLEVELS
35: #define pccompositesettype_ PCCOMPOSITESETTYPE
36: #define pccompositeaddpc_ PCCOMPOSITEADDPC
37: #define pccompositegetpc_ PCCOMPOSITEGETPC
38: #define pccompositespecialsetalpha_ PCCOMPOSITESETALPHA
39: #define pcshellsetsetup_ PCSHELLSETSETUP
40: #define pcilusetmatordering_ PCILUSETMATORDERING
41: #define pclusetmatordering_ PCLUSETMATORDERING
42: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
43: #define pcmgdefaultresidual_ pcmgdefaultresidual
44: #define pcmgsetresidual_ pcmgsetresidual
45: #define pcasmsetlocalsubdomains_ pcasmsetlocalsubdomains
46: #define pcasmsetglobalsubdomains_ pcasmsetglobalsubdomains
47: #define pcasmgetlocalsubmatrices_ pcasmgetlocalsubmatrices
48: #define pcasmgetlocalsubdomains_ pcasmgetlocalsubdomains
49: #define matnullspacecreate_ matnullspacecreate
50: #define pcregisterdestroy_ pcregisterdestroy
51: #define pcdestroy_ pcdestroy
52: #define pccreate_ pccreate
53: #define pcgetoperators_ pcgetoperators
54: #define pcgetfactoredmatrix_ pcgetfactoredmatrix
55: #define pcsetoptionsprefix_ pcsetoptionsprefix
56: #define pcappendoptionsprefix_ pcappendoptionsprefix
57: #define pcbjacobigetsubksp_ pcbjacobigetsubksp
58: #define pcasmgetsubksp_ pcasmgetsubksp
59: #define pcmggetcoarsesolve_ pcmggetcoarsesolve
60: #define pcmggetsmoother_ pcmggetsmoother
61: #define pcmggetsmootherup_ pcmggetsmootherup
62: #define pcmggetsmootherdown_ pcmggetsmootherdown
63: #define pcshellsetapplyrichardson_ pcshellsetapplyrichardson
64: #define pcshellsetapply_ pcshellsetapply
65: #define pcshellsetapplytranspose_ pcshellsetapplytranspose
66: #define pcgettype_ pcgettype
67: #define pcsettype_ pcsettype
68: #define pcgetoptionsprefix_ pcgetoptionsprefix
69: #define pcview_ pcview
70: #define pcmgsetlevels_ pcmgsetlevels
71: #define pccompositesettype_ pccompositesettype
72: #define pccompositeaddpc_ pccompositeaddpc
73: #define pccompositegetpc_ pccompositegetpc
74: #define pccompositespecialsetalpha_ pccompositespecialsetalpha
75: #define pcshellsetsetup_ pcshellsetsetup
76: #define pcilusetmatordering_ pcilusetmatordering
77: #define pclusetmatordering_ pclusetmatordering
78: #endif
81: static void (PETSC_STDCALL *f2)(void*,Vec*,Vec*,Vec*,PetscReal*,PetscReal*,PetscReal*,PetscInt*,PetscErrorCode*);
82: static void (PETSC_STDCALL *f1)(void*,Vec*,Vec*,PetscErrorCode*);
83: static void (PETSC_STDCALL *f3)(void*,Vec*,Vec*,PetscErrorCode*);
84: static void (PETSC_STDCALL *f9)(void*,PetscErrorCode*);
88: static PetscErrorCode ourapplyrichardson(void *ctx,Vec x,Vec y,Vec w,PetscReal rtol,PetscReal abstol,PetscReal dtol,PetscInt m)
89: {
90: PetscErrorCode 0;
92: (*f2)(ctx,&x,&y,&w,&rtol,&abstol,&dtol,&m,&ierr);
93: return 0;
94: }
96: static PetscErrorCode ourshellapply(void *ctx,Vec x,Vec y)
97: {
98: PetscErrorCode 0;
99: (*f1)(ctx,&x,&y,&ierr);
100: return 0;
101: }
103: static PetscErrorCode ourshellapplytranspose(void *ctx,Vec x,Vec y)
104: {
105: PetscErrorCode 0;
106: (*f3)(ctx,&x,&y,&ierr);
107: return 0;
108: }
110: static PetscErrorCode ourshellsetup(void *ctx)
111: {
112: PetscErrorCode 0;
114: (*f9)(ctx,&ierr);
115: return 0;
116: }
118: typedef PetscErrorCode (*MVVVV)(Mat,Vec,Vec,Vec);
119: static PetscErrorCode ourresidualfunction(Mat mat,Vec b,Vec x,Vec R)
120: {
121: PetscErrorCode 0;
122: (*(void (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&b,&x,&R,&ierr);
123: return 0;
124: }
127: void PETSC_STDCALL pccompositespecialsetalpha_(PC *pc,PetscScalar *alpha,PetscErrorCode *ierr)
128: {
129: *PCCompositeSpecialSetAlpha(*pc,*alpha);
130: }
132: void PETSC_STDCALL pccompositesettype_(PC *pc,PCCompositeType *type,PetscErrorCode *ierr)
133: {
134: *PCCompositeSetType(*pc,*type);
135: }
137: void PETSC_STDCALL pccompositeaddpc_(PC *pc,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
138: {
139: char *t;
141: FIXCHAR(type,len,t);
142: *PCCompositeAddPC(*pc,t);
143: FREECHAR(type,t);
144: }
146: void PETSC_STDCALL pccompositegetpc_(PC *pc,PetscInt *n,PC *subpc,PetscErrorCode *ierr)
147: {
148: *PCCompositeGetPC(*pc,*n,subpc);
149: }
151: void PETSC_STDCALL pcmgsetlevels_(PC *pc,PetscInt *levels,MPI_Comm *comms, PetscErrorCode *ierr)
152: {
153: CHKFORTRANNULLINTEGER(comms);
154: *PCMGSetLevels(*pc,*levels,comms);
155: }
157: void PETSC_STDCALL pcview_(PC *pc,PetscViewer *viewer, PetscErrorCode *ierr)
158: {
159: PetscViewer v;
160: PetscPatchDefaultViewers_Fortran(viewer,v);
161: *PCView(*pc,v);
162: }
164: void PETSC_STDCALL matnullspacecreate_(MPI_Comm *comm,PetscTruth *has_cnst,PetscInt *n,Vec *vecs,MatNullSpace *SP,PetscErrorCode *ierr)
165: {
166: *MatNullSpaceCreate((MPI_Comm)PetscToPointerComm(*comm),*has_cnst,*n,vecs,SP);
167: }
169: void PETSC_STDCALL pcsettype_(PC *pc,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
170: {
171: char *t;
173: FIXCHAR(type,len,t);
174: *PCSetType(*pc,t);
175: FREECHAR(type,t);
176: }
179: void PETSC_STDCALL pcshellsetapply_(PC *pc,void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,PetscErrorCode*),
180: PetscErrorCode *ierr)
181: {
182: f1 = apply;
183: *PCShellSetApply(*pc,ourshellapply);
184: }
186: void PETSC_STDCALL pcshellsetapplytranspose_(PC *pc,void (PETSC_STDCALL *applytranspose)(void*,Vec *,Vec *,PetscErrorCode*),
187: PetscErrorCode *ierr)
188: {
189: f3 = applytranspose;
190: *PCShellSetApplyTranspose(*pc,ourshellapplytranspose);
191: }
194: void PETSC_STDCALL pcshellsetsetup_(PC *pc,void (PETSC_STDCALL *setup)(void*,PetscErrorCode*),PetscErrorCode *ierr)
195: {
196: f9 = setup;
197: *PCShellSetSetUp(*pc,ourshellsetup);
198: }
200: /* -----------------------------------------------------------------*/
202: void PETSC_STDCALL pcshellsetapplyrichardson_(PC *pc,
203: void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,Vec *,PetscReal*,PetscReal*,PetscReal*,PetscInt*,PetscErrorCode*),
204: PetscErrorCode *ierr)
205: {
206: f2 = apply;
207: *PCShellSetApplyRichardson(*pc,ourapplyrichardson);
208: }
210: void PETSC_STDCALL pcmggetcoarsesolve_(PC *pc,KSP *ksp,PetscErrorCode *ierr)
211: {
212: *PCMGGetCoarseSolve(*pc,ksp);
213: }
215: void PETSC_STDCALL pcmggetsmoother_(PC *pc,PetscInt *l,KSP *ksp,PetscErrorCode *ierr)
216: {
217: *PCMGGetSmoother(*pc,*l,ksp);
218: }
220: void PETSC_STDCALL pcmggetsmootherup_(PC *pc,PetscInt *l,KSP *ksp,PetscErrorCode *ierr)
221: {
222: *PCMGGetSmootherUp(*pc,*l,ksp);
223: }
225: void PETSC_STDCALL pcmggetsmootherdown_(PC *pc,PetscInt *l,KSP *ksp,PetscErrorCode *ierr)
226: {
227: *PCMGGetSmootherDown(*pc,*l,ksp);
228: }
230: void PETSC_STDCALL pcbjacobigetsubksp_(PC *pc,PetscInt *n_local,PetscInt *first_local,KSP *ksp,PetscErrorCode *ierr)
231: {
232: KSP *tksp;
233: PetscInt i,nloc;
234: CHKFORTRANNULLINTEGER(n_local);
235: CHKFORTRANNULLINTEGER(first_local);
236: *PCBJacobiGetSubKSP(*pc,&nloc,first_local,&tksp);
237: if (n_local) *n_local = nloc;
238: for (i=0; i<nloc; i++){
239: ksp[i] = tksp[i];
240: }
241: }
243: void PETSC_STDCALL pcasmgetsubksp_(PC *pc,PetscInt *n_local,PetscInt *first_local,KSP *ksp,PetscErrorCode *ierr)
244: {
245: KSP *tksp;
246: PetscInt i,nloc;
247: CHKFORTRANNULLINTEGER(n_local);
248: CHKFORTRANNULLINTEGER(first_local);
249: *PCASMGetSubKSP(*pc,&nloc,first_local,&tksp);
250: if (n_local) *n_local = nloc;
251: for (i=0; i<nloc; i++){
252: ksp[i] = tksp[i];
253: }
254: }
256: void PETSC_STDCALL pcgetoperators_(PC *pc,Mat *mat,Mat *pmat,MatStructure *flag,PetscErrorCode *ierr)
257: {
258: CHKFORTRANNULLOBJECT(mat);
259: CHKFORTRANNULLOBJECT(pmat)
260: *PCGetOperators(*pc,mat,pmat,flag);
261: }
263: void PETSC_STDCALL pcgetfactoredmatrix_(PC *pc,Mat *mat,PetscErrorCode *ierr)
264: {
265: *PCGetFactoredMatrix(*pc,mat);
266: }
267:
268: void PETSC_STDCALL pcsetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
269: PetscErrorCode *ierr PETSC_END_LEN(len))
270: {
271: char *t;
273: FIXCHAR(prefix,len,t);
274: *PCSetOptionsPrefix(*pc,t);
275: FREECHAR(prefix,t);
276: }
278: void PETSC_STDCALL pcappendoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
279: PetscErrorCode *ierr PETSC_END_LEN(len))
280: {
281: char *t;
283: FIXCHAR(prefix,len,t);
284: *PCAppendOptionsPrefix(*pc,t);
285: FREECHAR(prefix,t);
286: }
288: void PETSC_STDCALL pcdestroy_(PC *pc,PetscErrorCode *ierr)
289: {
290: *PCDestroy(*pc);
291: }
293: void PETSC_STDCALL pccreate_(MPI_Comm *comm,PC *newpc,PetscErrorCode *ierr)
294: {
295: *PCCreate((MPI_Comm)PetscToPointerComm(*comm),newpc);
296: }
298: void PETSC_STDCALL pcregisterdestroy_(PetscErrorCode *ierr)
299: {
300: *PCRegisterDestroy();
301: }
303: void PETSC_STDCALL pcgettype_(PC *pc,CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
304: {
305: const char *tname;
307: *PCGetType(*pc,&tname);
308: #if defined(PETSC_USES_CPTOFCD)
309: {
310: char *t = _fcdtocp(name); int len1 = _fcdlen(name);
311: *PetscStrncpy(t,tname,len1); if (*ierr) return;
312: }
313: #else
314: *PetscStrncpy(name,tname,len);if (*ierr) return;
315: #endif
316: FIXRETURNCHAR(name,len);
318: }
320: void PETSC_STDCALL pcgetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
321: PetscErrorCode *ierr PETSC_END_LEN(len))
322: {
323: const char *tname;
325: *PCGetOptionsPrefix(*pc,&tname);
326: #if defined(PETSC_USES_CPTOFCD)
327: {
328: char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
329: *PetscStrncpy(t,tname,len1);if (*ierr) return;
330: }
331: #else
332: *PetscStrncpy(prefix,tname,len);if (*ierr) return;
333: #endif
334: }
336: void PETSC_STDCALL pcasmsetlocalsubdomains_(PC *pc,PetscInt *n,IS *is, PetscErrorCode *ierr)
337: {
338: CHKFORTRANNULLOBJECT(is);
339: *PCASMSetLocalSubdomains(*pc,*n,is);
340: }
342: void PETSC_STDCALL pcasmsettotalsubdomains_(PC *pc,PetscInt *N,IS *is, PetscErrorCode *ierr)
343: {
344: CHKFORTRANNULLOBJECT(is);
345: *PCASMSetTotalSubdomains(*pc,*N,is);
346: }
348: void PETSC_STDCALL pcasmgetlocalsubmatrices_(PC *pc,PetscInt *n,Mat *mat, PetscErrorCode *ierr)
349: {
350: PetscInt nloc,i;
351: Mat *tmat;
352: CHKFORTRANNULLOBJECT(mat);
353: CHKFORTRANNULLINTEGER(n);
354: *PCASMGetLocalSubmatrices(*pc,&nloc,&tmat);
355: if (n) *n = nloc;
356: if (mat) {
357: for (i=0; i<nloc; i++){
358: mat[i] = tmat[i];
359: }
360: }
361: }
362: void PETSC_STDCALL pcasmgetlocalsubdomains_(PC *pc,PetscInt *n,IS *is, PetscErrorCode *ierr)
363: {
364: PetscInt nloc,i;
365: IS *tis;
366: CHKFORTRANNULLOBJECT(is);
367: CHKFORTRANNULLINTEGER(n);
368: *PCASMGetLocalSubdomains(*pc,&nloc,&tis);
369: if (n) *n = nloc;
370: if (is) {
371: for (i=0; i<nloc; i++){
372: is[i] = tis[i];
373: }
374: }
375: }
377: void pcmgdefaultresidual_(Mat *mat,Vec *b,Vec *x,Vec *r, PetscErrorCode *ierr)
378: {
379: *PCMGDefaultResidual(*mat,*b,*x,*r);
380: }
382: void PETSC_STDCALL pcmgsetresidual_(PC *pc,PetscInt *l,PetscErrorCode (*residual)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*),Mat *mat, PetscErrorCode *ierr)
383: {
384: MVVVV rr;
385: if ((FCNVOID)residual == (FCNVOID)pcmgdefaultresidual_) rr = PCMGDefaultResidual;
386: else {
387: if (!((PetscObject)*mat)->fortran_func_pointers) {
388: *PetscMalloc(1*sizeof(void*),&((PetscObject)*mat)->fortran_func_pointers);
389: }
390: ((PetscObject)*mat)->fortran_func_pointers[0] = (FCNVOID)residual;
391: rr = ourresidualfunction;
392: }
393: *PCMGSetResidual(*pc,*l,rr,*mat);
394: }
396: void PETSC_STDCALL pcilusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), PetscErrorCode *ierr PETSC_END_LEN(len)){
397: char *t;
399: FIXCHAR(ordering,len,t);
400: *PCILUSetMatOrdering(*pc,t);
401: FREECHAR(ordering,t);
402: }
404: void PETSC_STDCALL pclusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), PetscErrorCode *ierr PETSC_END_LEN(len)){
405: char *t;
407: FIXCHAR(ordering,len,t);
408: *PCLUSetMatOrdering(*pc,t);
409: FREECHAR(ordering,t);
410: }
413: #ifdef PETSC_HAVE_FORTRAN_CAPS
414: #define pchypresettype_ PCHYPRESETTYPE
415: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) && !defined(FORTRANDOUBLEUNDERSCORE)
416: #define pchypresettype_ pchypresettype
417: #endif
419: #if defined(PETSC_HAVE_HYPRE) && !defined(PETSC_USE_COMPLEX)
421: #if defined(__cplusplus)
423: #endif
424: void PETSC_STDCALL pchypresettype_(PC *pc, CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len) )
425: {
426: char *t;
427: FIXCHAR(name,len,t);
428: *PCHYPRESetType(*pc,t);
429: FREECHAR(name,t);
430: }
431: #if defined(__cplusplus)
432: }
433: #endif
435: #endif