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 petscsles.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 pcbjacobigetsubsles_ PCBJACOBIGETSUBSLES
22: #define pcasmgetsubsles_ PCASMGETSUBSLES
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 pcbjacobigetsubsles_ pcbjacobigetsubsles
61: #define pcasmgetsubsles_ pcasmgetsubsles
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
85: void PETSC_STDCALL pccompositespecialsetalpha_(PC *pc,PetscScalar *alpha,int *ierr)
86: {
87: *PCCompositeSpecialSetAlpha(*pc,*alpha);
88: }
90: void PETSC_STDCALL pccompositesettype_(PC *pc,PCCompositeType *type,int *ierr)
91: {
92: *PCCompositeSetType(*pc,*type);
93: }
95: void PETSC_STDCALL pccompositeaddpc_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
96: {
97: char *t;
99: FIXCHAR(type,len,t);
100: *PCCompositeAddPC(*pc,t);
101: FREECHAR(type,t);
102: }
104: void PETSC_STDCALL pccompositegetpc_(PC *pc,int *n,PC *subpc,int *ierr)
105: {
106: *PCCompositeGetPC(*pc,*n,subpc);
107: }
109: void PETSC_STDCALL mgsetlevels_(PC *pc,int *levels,MPI_Comm *comms, int *ierr)
110: {
111: CHKFORTRANNULLOBJECT(comms);
112: *MGSetLevels(*pc,*levels,comms);
113: }
115: void PETSC_STDCALL pcview_(PC *pc,PetscViewer *viewer, int *ierr)
116: {
117: PetscViewer v;
118: PetscPatchDefaultViewers_Fortran(viewer,v);
119: *PCView(*pc,v);
120: }
122: void PETSC_STDCALL matnullspacecreate_(MPI_Comm *comm,int *has_cnst,int *n,Vec *vecs,MatNullSpace *SP,int *ierr)
123: {
124: *MatNullSpaceCreate((MPI_Comm)PetscToPointerComm(*comm),*has_cnst,*n,vecs,SP);
125: }
127: void PETSC_STDCALL pcnullspaceattach_(PC *pc,MatNullSpace *nullsp,int *ierr)
128: {
129: *PCNullSpaceAttach(*pc,*nullsp);
130: }
132: void PETSC_STDCALL pcsettype_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
133: {
134: char *t;
136: FIXCHAR(type,len,t);
137: *PCSetType(*pc,t);
138: FREECHAR(type,t);
139: }
142: static void (PETSC_STDCALL *f1)(void *,Vec*,Vec*,int*);
143: static int ourshellapply(void *ctx,Vec x,Vec y)
144: {
145: int 0;
146: (*f1)(ctx,&x,&y,&ierr);
147: return 0;
148: }
150: void PETSC_STDCALL pcshellsetapply_(PC *pc,void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,int*),void *ptr,
151: int *ierr)
152: {
153: f1 = apply;
154: *PCShellSetApply(*pc,ourshellapply,ptr);
155: }
157: static void (PETSC_STDCALL *f3)(void *,Vec*,Vec*,int*);
158: static int ourshellapplytranspose(void *ctx,Vec x,Vec y)
159: {
160: int 0;
161: (*f3)(ctx,&x,&y,&ierr);
162: return 0;
163: }
164: void PETSC_STDCALL pcshellsetapplytranspose_(PC *pc,void (PETSC_STDCALL *applytranspose)(void*,Vec *,Vec *,int*),
165: int *ierr)
166: {
167: f3 = applytranspose;
168: *PCShellSetApplyTranspose(*pc,ourshellapplytranspose);
169: }
171: static void (PETSC_STDCALL *f9)(void *,int*);
172: static int ourshellsetup(void *ctx)
173: {
174: int 0;
176: (*f9)(ctx,&ierr);
177: return 0;
178: }
180: void PETSC_STDCALL pcshellsetsetup_(PC *pc,void (PETSC_STDCALL *setup)(void*,int*),int *ierr)
181: {
182: f9 = setup;
183: *PCShellSetSetUp(*pc,ourshellsetup);
184: }
186: /* -----------------------------------------------------------------*/
187: static void (PETSC_STDCALL *f2)(void*,Vec*,Vec*,Vec*,PetscReal*,PetscReal*,PetscReal*,int*,int*);
188: static int ourapplyrichardson(void *ctx,Vec x,Vec y,Vec w,PetscReal rtol,PetscReal atol,PetscReal dtol,int m)
189: {
190: int 0;
192: (*f2)(ctx,&x,&y,&w,&rtol,&atol,&dtol,&m,&ierr);
193: return 0;
194: }
196: void PETSC_STDCALL pcshellsetapplyrichardson_(PC *pc,
197: void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,Vec *,PetscReal*,PetscReal*,PetscReal*,int*,int*),
198: void *ptr,int *ierr)
199: {
200: f2 = apply;
201: *PCShellSetApplyRichardson(*pc,ourapplyrichardson,ptr);
202: }
204: void PETSC_STDCALL mggetcoarsesolve_(PC *pc,SLES *sles,int *ierr)
205: {
206: *MGGetCoarseSolve(*pc,sles);
207: }
209: void PETSC_STDCALL mggetsmoother_(PC *pc,int *l,SLES *sles,int *ierr)
210: {
211: *MGGetSmoother(*pc,*l,sles);
212: }
214: void PETSC_STDCALL mggetsmootherup_(PC *pc,int *l,SLES *sles,int *ierr)
215: {
216: *MGGetSmootherUp(*pc,*l,sles);
217: }
219: void PETSC_STDCALL mggetsmootherdown_(PC *pc,int *l,SLES *sles,int *ierr)
220: {
221: *MGGetSmootherDown(*pc,*l,sles);
222: }
224: void PETSC_STDCALL pcbjacobigetsubsles_(PC *pc,int *n_local,int *first_local,SLES *sles,int *ierr)
225: {
226: SLES *tsles;
227: int i,nloc;
228: CHKFORTRANNULLINTEGER(n_local);
229: CHKFORTRANNULLINTEGER(first_local);
230: *PCBJacobiGetSubSLES(*pc,&nloc,first_local,&tsles);
231: if (n_local) *n_local = nloc;
232: for (i=0; i<nloc; i++){
233: sles[i] = tsles[i];
234: }
235: }
237: void PETSC_STDCALL pcasmgetsubsles_(PC *pc,int *n_local,int *first_local,SLES *sles,int *ierr)
238: {
239: SLES *tsles;
240: int i,nloc;
241: CHKFORTRANNULLINTEGER(n_local);
242: CHKFORTRANNULLINTEGER(first_local);
243: *PCASMGetSubSLES(*pc,&nloc,first_local,&tsles);
244: if (n_local) *n_local = nloc;
245: for (i=0; i<nloc; i++){
246: sles[i] = tsles[i];
247: }
248: }
250: void PETSC_STDCALL pcgetoperators_(PC *pc,Mat *mat,Mat *pmat,MatStructure *flag,int *ierr)
251: {
252: CHKFORTRANNULLINTEGER(flag);
253: CHKFORTRANNULLOBJECT(mat);
254: CHKFORTRANNULLOBJECT(pmat)
255: *PCGetOperators(*pc,mat,pmat,flag);
256: }
258: void PETSC_STDCALL pcgetfactoredmatrix_(PC *pc,Mat *mat,int *ierr)
259: {
260: *PCGetFactoredMatrix(*pc,mat);
261: }
262:
263: void PETSC_STDCALL pcsetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
264: int *ierr PETSC_END_LEN(len))
265: {
266: char *t;
268: FIXCHAR(prefix,len,t);
269: *PCSetOptionsPrefix(*pc,t);
270: FREECHAR(prefix,t);
271: }
273: void PETSC_STDCALL pcappendoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
274: int *ierr PETSC_END_LEN(len))
275: {
276: char *t;
278: FIXCHAR(prefix,len,t);
279: *PCAppendOptionsPrefix(*pc,t);
280: FREECHAR(prefix,t);
281: }
283: void PETSC_STDCALL pcdestroy_(PC *pc,int *ierr)
284: {
285: *PCDestroy(*pc);
286: }
288: void PETSC_STDCALL pccreate_(MPI_Comm *comm,PC *newpc,int *ierr)
289: {
290: *PCCreate((MPI_Comm)PetscToPointerComm(*comm),newpc);
291: }
293: void PETSC_STDCALL pcregisterdestroy_(int *ierr)
294: {
295: *PCRegisterDestroy();
296: }
298: void PETSC_STDCALL pcgettype_(PC *pc,CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
299: {
300: char *tname;
302: *PCGetType(*pc,&tname);
303: #if defined(PETSC_USES_CPTOFCD)
304: {
305: char *t = _fcdtocp(name); int len1 = _fcdlen(name);
306: *PetscStrncpy(t,tname,len1); if (*ierr) return;
307: }
308: #else
309: *PetscStrncpy(name,tname,len);if (*ierr) return;
310: #endif
311: }
313: void PETSC_STDCALL pcgetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
314: int *ierr PETSC_END_LEN(len))
315: {
316: char *tname;
318: *PCGetOptionsPrefix(*pc,&tname);
319: #if defined(PETSC_USES_CPTOFCD)
320: {
321: char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
322: *PetscStrncpy(t,tname,len1);if (*ierr) return;
323: }
324: #else
325: *PetscStrncpy(prefix,tname,len);if (*ierr) return;
326: #endif
327: }
329: void PETSC_STDCALL pcasmsetlocalsubdomains_(PC *pc,int *n,IS *is, int *ierr)
330: {
331: CHKFORTRANNULLOBJECT(is);
332: *PCASMSetLocalSubdomains(*pc,*n,is);
333: }
335: void PETSC_STDCALL pcasmsettotalsubdomains_(PC *pc,int *N,IS *is, int *ierr)
336: {
337: CHKFORTRANNULLOBJECT(is);
338: *PCASMSetTotalSubdomains(*pc,*N,is);
339: }
341: void PETSC_STDCALL pcasmgetlocalsubmatrices_(PC *pc,int *n,Mat *mat, int *ierr)
342: {
343: int nloc,i;
344: Mat *tmat;
345: CHKFORTRANNULLOBJECT(mat);
346: CHKFORTRANNULLINTEGER(n);
347: *PCASMGetLocalSubmatrices(*pc,&nloc,&tmat);
348: if (n) *n = nloc;
349: if (mat) {
350: for (i=0; i<nloc; i++){
351: mat[i] = tmat[i];
352: }
353: }
354: }
355: void PETSC_STDCALL pcasmgetlocalsubdomains_(PC *pc,int *n,IS *is, int *ierr)
356: {
357: int nloc,i;
358: IS *tis;
359: CHKFORTRANNULLOBJECT(is);
360: CHKFORTRANNULLINTEGER(n);
361: *PCASMGetLocalSubdomains(*pc,&nloc,&tis);
362: if (n) *n = nloc;
363: if (is) {
364: for (i=0; i<nloc; i++){
365: is[i] = tis[i];
366: }
367: }
368: }
370: void mgdefaultresidual_(Mat *mat,Vec *b,Vec *x,Vec *r, int *ierr)
371: {
372: *MGDefaultResidual(*mat,*b,*x,*r);
373: }
375: static int ourresidualfunction(Mat mat,Vec b,Vec x,Vec R)
376: {
377: int 0;
378: (*(void (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&b,&x,&R,&ierr);
379: return 0;
380: }
382: void PETSC_STDCALL mgsetresidual_(PC *pc,int *l,int (*residual)(Mat*,Vec*,Vec*,Vec*,int*),Mat *mat, int *ierr)
383: {
384: int (*rr)(Mat,Vec,Vec,Vec);
385: if ((void(*)(void))residual == (void(*)(void))mgdefaultresidual_) rr = MGDefaultResidual;
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] = (void(*)(void))residual;
391: rr = ourresidualfunction;
392: }
393: *MGSetResidual(*pc,*l,rr,*mat);
394: }
396: void PETSC_STDCALL pcilusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), int *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), int *ierr PETSC_END_LEN(len)){
405: char *t;
407: FIXCHAR(ordering,len,t);
408: *PCLUSetMatOrdering(*pc,t);
409: FREECHAR(ordering,t);
410: }
412: EXTERN_C_END