Actual source code: zpc.c
1: /*$Id: zpc.c,v 1.51 2001/08/06 21:19:11 bsmith Exp $*/
3: #include src/fortran/custom/zpetsc.h
4: #include petscksp.h
5: #include petscmg.h
7: #ifdef PETSC_HAVE_FORTRAN_CAPS
8: #define mgdefaultresidual_ MGDEFAULTRESIDUAL
9: #define mgsetresidual_ MGSETRESIDUAL
10: #define pcasmsetlocalsubdomains_ PCASMSETLOCALSUBDOMAINS
11: #define pcasmsetglobalsubdomains_ PCASMSETGLOBALSUBDOMAINS
12: #define pcasmgetlocalsubmatrices_ PCASMGETLOCALSUBMATRICES
13: #define pcasmgetlocalsubdomains_ PCASMGETLOCALSUBDOMAINS
14: #define pcregisterdestroy_ PCREGISTERDESTROY
15: #define pcdestroy_ PCDESTROY
16: #define pccreate_ PCCREATE
17: #define pcgetoperators_ PCGETOPERATORS
18: #define pcgetfactoredmatrix_ PCGETFACTOREDMATRIX
19: #define pcsetoptionsprefix_ PCSETOPTIONSPREFIX
20: #define pcappendoptionsprefix_ PCAPPENDOPTIONSPREFIX
21: #define pcbjacobigetsubksp_ PCBJACOBIGETSUBKSP
22: #define pcasmgetsubksp_ PCASMGETSUBKSP
23: #define mggetcoarsesolve_ MGGETCOARSESOLVE
24: #define mggetsmoother_ MGGETSMOOTHER
25: #define mggetsmootherup_ MGGETSMOOTHERUP
26: #define mggetsmootherdown_ MGGETSMOOTHERDOWN
27: #define pcshellsetapply_ PCSHELLSETAPPLY
28: #define pcshellsetapplytranspose_ PCSHELLSETAPPLYTRANSPOSE
29: #define pcshellsetapplyrichardson_ PCSHELLSETAPPLYRICHARDSON
30: #define pcgettype_ PCGETTYPE
31: #define pcsettype_ PCSETTYPE
32: #define pcgetoptionsprefix_ PCGETOPTIONSPREFIX
33: #define pcnullspaceattach_ PCNULLSPACEATTACH
34: #define matnullspacecreate_ MATNULLSPACECREATE
35: #define pcview_ PCVIEW
36: #define mgsetlevels_ MGSETLEVELS
37: #define pccompositesettype_ PCCOMPOSITESETTYPE
38: #define pccompositeaddpc_ PCCOMPOSITEADDPC
39: #define pccompositegetpc_ PCCOMPOSITEGETPC
40: #define pccompositespecialsetalpha_ PCCOMPOSITESETALPHA
41: #define pcshellsetsetup_ PCSHELLSETSETUP
42: #define pcilusetmatordering_ PCILUSETMATORDERING
43: #define pclusetmatordering_ PCLUSETMATORDERING
44: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
45: #define mgdefaultresidual_ mgdefaultresidual
46: #define mgsetresidual_ mgsetresidual
47: #define pcasmsetlocalsubdomains_ pcasmsetlocalsubdomains
48: #define pcasmsetglobalsubdomains_ pcasmsetglobalsubdomains
49: #define pcasmgetlocalsubmatrices_ pcasmgetlocalsubmatrices
50: #define pcasmgetlocalsubdomains_ pcasmgetlocalsubdomains
51: #define matnullspacecreate_ matnullspacecreate
52: #define pcnullspaceattach_ pcnullspaceattach
53: #define pcregisterdestroy_ pcregisterdestroy
54: #define pcdestroy_ pcdestroy
55: #define pccreate_ pccreate
56: #define pcgetoperators_ pcgetoperators
57: #define pcgetfactoredmatrix_ pcgetfactoredmatrix
58: #define pcsetoptionsprefix_ pcsetoptionsprefix
59: #define pcappendoptionsprefix_ pcappendoptionsprefix
60: #define pcbjacobigetsubksp_ pcbjacobigetsubksp
61: #define pcasmgetsubksp_ pcasmgetsubksp
62: #define mggetcoarsesolve_ mggetcoarsesolve
63: #define mggetsmoother_ mggetsmoother
64: #define mggetsmootherup_ mggetsmootherup
65: #define mggetsmootherdown_ mggetsmootherdown
66: #define pcshellsetapplyrichardson_ pcshellsetapplyrichardson
67: #define pcshellsetapply_ pcshellsetapply
68: #define pcshellsetapplytranspose_ pcshellsetapplytranspose
69: #define pcgettype_ pcgettype
70: #define pcsettype_ pcsettype
71: #define pcgetoptionsprefix_ pcgetoptionsprefix
72: #define pcview_ pcview
73: #define mgsetlevels_ mgsetlevels
74: #define pccompositesettype_ pccompositesettype
75: #define pccompositeaddpc_ pccompositeaddpc
76: #define pccompositegetpc_ pccompositegetpc
77: #define pccompositespecialsetalpha_ pccompositespecialsetalpha
78: #define pcshellsetsetup_ pcshellsetsetup
79: #define pcilusetmatordering_ pcilusetmatordering
80: #define pclusetmatordering_ pclusetmatordering
81: #endif
83: EXTERN_C_BEGIN
84: static void (PETSC_STDCALL *f2)(void*,Vec*,Vec*,Vec*,PetscReal*,PetscReal*,PetscReal*,int*,int*);
85: static void (PETSC_STDCALL *f1)(void *,Vec*,Vec*,int*);
86: static void (PETSC_STDCALL *f3)(void *,Vec*,Vec*,int*);
87: static void (PETSC_STDCALL *f9)(void *,int*);
88: EXTERN_C_END
90: /* These are not extern C because they are passed into non-extern C user level functions */
91: static int ourapplyrichardson(void *ctx,Vec x,Vec y,Vec w,PetscReal rtol,PetscReal atol,PetscReal dtol,int m)
92: {
93: int 0;
95: (*f2)(ctx,&x,&y,&w,&rtol,&atol,&dtol,&m,&ierr);
96: return 0;
97: }
99: static int ourshellapply(void *ctx,Vec x,Vec y)
100: {
101: int 0;
102: (*f1)(ctx,&x,&y,&ierr);
103: return 0;
104: }
106: static int ourshellapplytranspose(void *ctx,Vec x,Vec y)
107: {
108: int 0;
109: (*f3)(ctx,&x,&y,&ierr);
110: return 0;
111: }
113: static int ourshellsetup(void *ctx)
114: {
115: int 0;
117: (*f9)(ctx,&ierr);
118: return 0;
119: }
121: typedef int (*MVVVV)(Mat,Vec,Vec,Vec);
122: static int ourresidualfunction(Mat mat,Vec b,Vec x,Vec R)
123: {
124: int 0;
125: (*(void (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&b,&x,&R,&ierr);
126: return 0;
127: }
129: EXTERN_C_BEGIN
130: void PETSC_STDCALL pccompositespecialsetalpha_(PC *pc,PetscScalar *alpha,int *ierr)
131: {
132: *PCCompositeSpecialSetAlpha(*pc,*alpha);
133: }
135: void PETSC_STDCALL pccompositesettype_(PC *pc,PCCompositeType *type,int *ierr)
136: {
137: *PCCompositeSetType(*pc,*type);
138: }
140: void PETSC_STDCALL pccompositeaddpc_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
141: {
142: char *t;
144: FIXCHAR(type,len,t);
145: *PCCompositeAddPC(*pc,t);
146: FREECHAR(type,t);
147: }
149: void PETSC_STDCALL pccompositegetpc_(PC *pc,int *n,PC *subpc,int *ierr)
150: {
151: *PCCompositeGetPC(*pc,*n,subpc);
152: }
154: void PETSC_STDCALL mgsetlevels_(PC *pc,int *levels,MPI_Comm *comms, int *ierr)
155: {
156: CHKFORTRANNULLOBJECT(comms);
157: *MGSetLevels(*pc,*levels,comms);
158: }
160: void PETSC_STDCALL pcview_(PC *pc,PetscViewer *viewer, int *ierr)
161: {
162: PetscViewer v;
163: PetscPatchDefaultViewers_Fortran(viewer,v);
164: *PCView(*pc,v);
165: }
167: void PETSC_STDCALL matnullspacecreate_(MPI_Comm *comm,int *has_cnst,int *n,Vec *vecs,MatNullSpace *SP,int *ierr)
168: {
169: *MatNullSpaceCreate((MPI_Comm)PetscToPointerComm(*comm),*has_cnst,*n,vecs,SP);
170: }
172: void PETSC_STDCALL pcnullspaceattach_(PC *pc,MatNullSpace *nullsp,int *ierr)
173: {
174: *PCNullSpaceAttach(*pc,*nullsp);
175: }
177: void PETSC_STDCALL pcsettype_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
178: {
179: char *t;
181: FIXCHAR(type,len,t);
182: *PCSetType(*pc,t);
183: FREECHAR(type,t);
184: }
187: void PETSC_STDCALL pcshellsetapply_(PC *pc,void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,int*),void *ptr,
188: int *ierr)
189: {
190: f1 = apply;
191: *PCShellSetApply(*pc,ourshellapply,ptr);
192: }
194: void PETSC_STDCALL pcshellsetapplytranspose_(PC *pc,void (PETSC_STDCALL *applytranspose)(void*,Vec *,Vec *,int*),
195: int *ierr)
196: {
197: f3 = applytranspose;
198: *PCShellSetApplyTranspose(*pc,ourshellapplytranspose);
199: }
202: void PETSC_STDCALL pcshellsetsetup_(PC *pc,void (PETSC_STDCALL *setup)(void*,int*),int *ierr)
203: {
204: f9 = setup;
205: *PCShellSetSetUp(*pc,ourshellsetup);
206: }
208: /* -----------------------------------------------------------------*/
210: void PETSC_STDCALL pcshellsetapplyrichardson_(PC *pc,
211: void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,Vec *,PetscReal*,PetscReal*,PetscReal*,int*,int*),
212: void *ptr,int *ierr)
213: {
214: f2 = apply;
215: *PCShellSetApplyRichardson(*pc,ourapplyrichardson,ptr);
216: }
218: void PETSC_STDCALL mggetcoarsesolve_(PC *pc,KSP *ksp,int *ierr)
219: {
220: *MGGetCoarseSolve(*pc,ksp);
221: }
223: void PETSC_STDCALL mggetsmoother_(PC *pc,int *l,KSP *ksp,int *ierr)
224: {
225: *MGGetSmoother(*pc,*l,ksp);
226: }
228: void PETSC_STDCALL mggetsmootherup_(PC *pc,int *l,KSP *ksp,int *ierr)
229: {
230: *MGGetSmootherUp(*pc,*l,ksp);
231: }
233: void PETSC_STDCALL mggetsmootherdown_(PC *pc,int *l,KSP *ksp,int *ierr)
234: {
235: *MGGetSmootherDown(*pc,*l,ksp);
236: }
238: void PETSC_STDCALL pcbjacobigetsubksp_(PC *pc,int *n_local,int *first_local,KSP *ksp,int *ierr)
239: {
240: KSP *tksp;
241: int i,nloc;
242: CHKFORTRANNULLINTEGER(n_local);
243: CHKFORTRANNULLINTEGER(first_local);
244: *PCBJacobiGetSubKSP(*pc,&nloc,first_local,&tksp);
245: if (n_local) *n_local = nloc;
246: for (i=0; i<nloc; i++){
247: ksp[i] = tksp[i];
248: }
249: }
251: void PETSC_STDCALL pcasmgetsubksp_(PC *pc,int *n_local,int *first_local,KSP *ksp,int *ierr)
252: {
253: KSP *tksp;
254: int i,nloc;
255: CHKFORTRANNULLINTEGER(n_local);
256: CHKFORTRANNULLINTEGER(first_local);
257: *PCASMGetSubKSP(*pc,&nloc,first_local,&tksp);
258: if (n_local) *n_local = nloc;
259: for (i=0; i<nloc; i++){
260: ksp[i] = tksp[i];
261: }
262: }
264: void PETSC_STDCALL pcgetoperators_(PC *pc,Mat *mat,Mat *pmat,MatStructure *flag,int *ierr)
265: {
266: CHKFORTRANNULLINTEGER(flag);
267: CHKFORTRANNULLOBJECT(mat);
268: CHKFORTRANNULLOBJECT(pmat)
269: *PCGetOperators(*pc,mat,pmat,flag);
270: }
272: void PETSC_STDCALL pcgetfactoredmatrix_(PC *pc,Mat *mat,int *ierr)
273: {
274: *PCGetFactoredMatrix(*pc,mat);
275: }
276:
277: void PETSC_STDCALL pcsetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
278: int *ierr PETSC_END_LEN(len))
279: {
280: char *t;
282: FIXCHAR(prefix,len,t);
283: *PCSetOptionsPrefix(*pc,t);
284: FREECHAR(prefix,t);
285: }
287: void PETSC_STDCALL pcappendoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
288: int *ierr PETSC_END_LEN(len))
289: {
290: char *t;
292: FIXCHAR(prefix,len,t);
293: *PCAppendOptionsPrefix(*pc,t);
294: FREECHAR(prefix,t);
295: }
297: void PETSC_STDCALL pcdestroy_(PC *pc,int *ierr)
298: {
299: *PCDestroy(*pc);
300: }
302: void PETSC_STDCALL pccreate_(MPI_Comm *comm,PC *newpc,int *ierr)
303: {
304: *PCCreate((MPI_Comm)PetscToPointerComm(*comm),newpc);
305: }
307: void PETSC_STDCALL pcregisterdestroy_(int *ierr)
308: {
309: *PCRegisterDestroy();
310: }
312: void PETSC_STDCALL pcgettype_(PC *pc,CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
313: {
314: char *tname;
316: *PCGetType(*pc,&tname);
317: #if defined(PETSC_USES_CPTOFCD)
318: {
319: char *t = _fcdtocp(name); int len1 = _fcdlen(name);
320: *PetscStrncpy(t,tname,len1); if (*ierr) return;
321: }
322: #else
323: *PetscStrncpy(name,tname,len);if (*ierr) return;
324: #endif
325: }
327: void PETSC_STDCALL pcgetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
328: int *ierr PETSC_END_LEN(len))
329: {
330: char *tname;
332: *PCGetOptionsPrefix(*pc,&tname);
333: #if defined(PETSC_USES_CPTOFCD)
334: {
335: char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
336: *PetscStrncpy(t,tname,len1);if (*ierr) return;
337: }
338: #else
339: *PetscStrncpy(prefix,tname,len);if (*ierr) return;
340: #endif
341: }
343: void PETSC_STDCALL pcasmsetlocalsubdomains_(PC *pc,int *n,IS *is, int *ierr)
344: {
345: CHKFORTRANNULLOBJECT(is);
346: *PCASMSetLocalSubdomains(*pc,*n,is);
347: }
349: void PETSC_STDCALL pcasmsettotalsubdomains_(PC *pc,int *N,IS *is, int *ierr)
350: {
351: CHKFORTRANNULLOBJECT(is);
352: *PCASMSetTotalSubdomains(*pc,*N,is);
353: }
355: void PETSC_STDCALL pcasmgetlocalsubmatrices_(PC *pc,int *n,Mat *mat, int *ierr)
356: {
357: int nloc,i;
358: Mat *tmat;
359: CHKFORTRANNULLOBJECT(mat);
360: CHKFORTRANNULLINTEGER(n);
361: *PCASMGetLocalSubmatrices(*pc,&nloc,&tmat);
362: if (n) *n = nloc;
363: if (mat) {
364: for (i=0; i<nloc; i++){
365: mat[i] = tmat[i];
366: }
367: }
368: }
369: void PETSC_STDCALL pcasmgetlocalsubdomains_(PC *pc,int *n,IS *is, int *ierr)
370: {
371: int nloc,i;
372: IS *tis;
373: CHKFORTRANNULLOBJECT(is);
374: CHKFORTRANNULLINTEGER(n);
375: *PCASMGetLocalSubdomains(*pc,&nloc,&tis);
376: if (n) *n = nloc;
377: if (is) {
378: for (i=0; i<nloc; i++){
379: is[i] = tis[i];
380: }
381: }
382: }
384: void mgdefaultresidual_(Mat *mat,Vec *b,Vec *x,Vec *r, int *ierr)
385: {
386: *MGDefaultResidual(*mat,*b,*x,*r);
387: }
389: void PETSC_STDCALL mgsetresidual_(PC *pc,int *l,int (*residual)(Mat*,Vec*,Vec*,Vec*,int*),Mat *mat, int *ierr)
390: {
391: MVVVV rr;
392: if ((FCNVOID)residual == (FCNVOID)mgdefaultresidual_) rr = MGDefaultResidual;
393: else {
394: if (!((PetscObject)*mat)->fortran_func_pointers) {
395: *PetscMalloc(1*sizeof(void *),&((PetscObject)*mat)->fortran_func_pointers);
396: }
397: ((PetscObject)*mat)->fortran_func_pointers[0] = (FCNVOID)residual;
398: rr = ourresidualfunction;
399: }
400: *MGSetResidual(*pc,*l,rr,*mat);
401: }
403: void PETSC_STDCALL pcilusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), int *ierr PETSC_END_LEN(len)){
404: char *t;
406: FIXCHAR(ordering,len,t);
407: *PCILUSetMatOrdering(*pc,t);
408: FREECHAR(ordering,t);
409: }
411: void PETSC_STDCALL pclusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), int *ierr PETSC_END_LEN(len)){
412: char *t;
414: FIXCHAR(ordering,len,t);
415: *PCLUSetMatOrdering(*pc,t);
416: FREECHAR(ordering,t);
417: }
419: EXTERN_C_END