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 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 pcbjacobigetsubsles_ PCBJACOBIGETSUBSLES
21: #define pcasmgetsubsles_ PCASMGETSUBSLES
22: #define mggetcoarsesolve_ MGGETCOARSESOLVE
23: #define mggetsmoother_ MGGETSMOOTHER
24: #define mggetsmootherup_ MGGETSMOOTHERUP
25: #define mggetsmootherdown_ MGGETSMOOTHERDOWN
26: #define pcshellsetapply_ PCSHELLSETAPPLY
27: #define pcshellsetapplyrichardson_ PCSHELLSETAPPLYRICHARDSON
28: #define pcgettype_ PCGETTYPE
29: #define pcsettype_ PCSETTYPE
30: #define pcgetoptionsprefix_ PCGETOPTIONSPREFIX
31: #define pcnullspaceattach_ PCNULLSPACEATTACH
32: #define matnullspacecreate_ MATNULLSPACECREATE
33: #define pcview_ PCVIEW
34: #define mgsetlevels_ MGSETLEVELS
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 mgdefaultresidual_ mgdefaultresidual
44: #define mgsetresidual_ mgsetresidual
45: #define pcasmsetlocalsubdomains_ pcasmsetlocalsubdomains
46: #define pcasmsetglobalsubdomains_ pcasmsetglobalsubdomains
47: #define pcasmgetlocalsubdomains_ pcasmgetlocalsubdomains
48: #define matnullspacecreate_ matnullspacecreate
49: #define pcnullspaceattach_ pcnullspaceattach
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 pcbjacobigetsubsles_ pcbjacobigetsubsles
58: #define pcasmgetsubsles_ pcasmgetsubsles
59: #define mggetcoarsesolve_ mggetcoarsesolve
60: #define mggetsmoother_ mggetsmoother
61: #define mggetsmootherup_ mggetsmootherup
62: #define mggetsmootherdown_ mggetsmootherdown
63: #define pcshellsetapplyrichardson_ pcshellsetapplyrichardson
64: #define pcshellsetapply_ pcshellsetapply
65: #define pcgettype_ pcgettype
66: #define pcsettype_ pcsettype
67: #define pcgetoptionsprefix_ pcgetoptionsprefix
68: #define pcview_ pcview
69: #define mgsetlevels_ mgsetlevels
70: #define pccompositesettype_ pccompositesettype
71: #define pccompositeaddpc_ pccompositeaddpc
72: #define pccompositegetpc_ pccompositegetpc
73: #define pccompositespecialsetalpha_ pccompositespecialsetalpha
74: #define pcshellsetsetup_ pcshellsetsetup
75: #define pcilusetmatordering_ pcilusetmatordering
76: #define pclusetmatordering_ pclusetmatordering
77: #endif
79: EXTERN_C_BEGIN
81: void PETSC_STDCALL pccompositespecialsetalpha_(PC *pc,PetscScalar *alpha,int *ierr)
82: {
83: *PCCompositeSpecialSetAlpha(*pc,*alpha);
84: }
86: void PETSC_STDCALL pccompositesettype_(PC *pc,PCCompositeType *type,int *ierr)
87: {
88: *PCCompositeSetType(*pc,*type);
89: }
91: void PETSC_STDCALL pccompositeaddpc_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
92: {
93: char *t;
95: FIXCHAR(type,len,t);
96: *PCCompositeAddPC(*pc,t);
97: FREECHAR(type,t);
98: }
100: void PETSC_STDCALL pccompositegetpc_(PC *pc,int *n,PC *subpc,int *ierr)
101: {
102: *PCCompositeGetPC(*pc,*n,subpc);
103: }
105: void PETSC_STDCALL mgsetlevels_(PC *pc,int *levels,MPI_Comm *comms, int *ierr)
106: {
107: CHKFORTRANNULLOBJECT(comms);
108: *MGSetLevels(*pc,*levels,comms);
109: }
111: void PETSC_STDCALL pcview_(PC *pc,PetscViewer *viewer, int *ierr)
112: {
113: PetscViewer v;
114: PetscPatchDefaultViewers_Fortran(viewer,v);
115: *PCView(*pc,v);
116: }
118: void PETSC_STDCALL matnullspacecreate_(MPI_Comm *comm,int *has_cnst,int *n,Vec *vecs,MatNullSpace *SP,int *ierr)
119: {
120: *MatNullSpaceCreate((MPI_Comm)PetscToPointerComm(*comm),*has_cnst,*n,vecs,SP);
121: }
123: void PETSC_STDCALL pcnullspaceattach_(PC *pc,MatNullSpace *nullsp,int *ierr)
124: {
125: *PCNullSpaceAttach(*pc,*nullsp);
126: }
128: void PETSC_STDCALL pcsettype_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
129: {
130: char *t;
132: FIXCHAR(type,len,t);
133: *PCSetType(*pc,t);
134: FREECHAR(type,t);
135: }
138: static void (PETSC_STDCALL *f1)(void *,Vec*,Vec*,int*);
139: static int ourshellapply(void *ctx,Vec x,Vec y)
140: {
141: int 0;
142: (*f1)(ctx,&x,&y,&ierr);
143: return 0;
144: }
146: void PETSC_STDCALL pcshellsetapply_(PC *pc,void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,int*),void *ptr,
147: int *ierr)
148: {
149: f1 = apply;
150: *PCShellSetApply(*pc,ourshellapply,ptr);
151: }
153: static void (PETSC_STDCALL *f9)(void *,int*);
154: static int ourshellsetup(void *ctx)
155: {
156: int 0;
158: (*f9)(ctx,&ierr);
159: return 0;
160: }
162: void PETSC_STDCALL pcshellsetsetup_(PC *pc,void (PETSC_STDCALL *setup)(void*,int*),int *ierr)
163: {
164: f9 = setup;
165: *PCShellSetSetUp(*pc,ourshellsetup);
166: }
168: /* -----------------------------------------------------------------*/
169: static void (PETSC_STDCALL *f2)(void*,Vec*,Vec*,Vec*,PetscReal*,PetscReal*,PetscReal*,int*,int*);
170: static int ourapplyrichardson(void *ctx,Vec x,Vec y,Vec w,PetscReal rtol,PetscReal atol,PetscReal dtol,int m)
171: {
172: int 0;
174: (*f2)(ctx,&x,&y,&w,&rtol,&atol,&dtol,&m,&ierr);
175: return 0;
176: }
178: void PETSC_STDCALL pcshellsetapplyrichardson_(PC *pc,
179: void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,Vec *,PetscReal*,PetscReal*,PetscReal*,int*,int*),
180: void *ptr,int *ierr)
181: {
182: f2 = apply;
183: *PCShellSetApplyRichardson(*pc,ourapplyrichardson,ptr);
184: }
186: void PETSC_STDCALL mggetcoarsesolve_(PC *pc,SLES *sles,int *ierr)
187: {
188: *MGGetCoarseSolve(*pc,sles);
189: }
191: void PETSC_STDCALL mggetsmoother_(PC *pc,int *l,SLES *sles,int *ierr)
192: {
193: *MGGetSmoother(*pc,*l,sles);
194: }
196: void PETSC_STDCALL mggetsmootherup_(PC *pc,int *l,SLES *sles,int *ierr)
197: {
198: *MGGetSmootherUp(*pc,*l,sles);
199: }
201: void PETSC_STDCALL mggetsmootherdown_(PC *pc,int *l,SLES *sles,int *ierr)
202: {
203: *MGGetSmootherDown(*pc,*l,sles);
204: }
206: void PETSC_STDCALL pcbjacobigetsubsles_(PC *pc,int *n_local,int *first_local,SLES *sles,int *ierr)
207: {
208: SLES *tsles;
209: int i;
210: CHKFORTRANNULLINTEGER(n_local);
211: CHKFORTRANNULLINTEGER(first_local);
212: *PCBJacobiGetSubSLES(*pc,n_local,first_local,&tsles);
213: for (i=0; i<*n_local; i++){
214: sles[i] = tsles[i];
215: }
216: }
218: void PETSC_STDCALL pcasmgetsubsles_(PC *pc,int *n_local,int *first_local,SLES *sles,int *ierr)
219: {
220: SLES *tsles;
221: int i,nloc;
222: CHKFORTRANNULLINTEGER(n_local);
223: CHKFORTRANNULLINTEGER(first_local);
224: *PCASMGetSubSLES(*pc,&nloc,first_local,&tsles);
225: if (n_local) *n_local = nloc;
226: for (i=0; i<nloc; i++){
227: sles[i] = tsles[i];
228: }
229: }
231: void PETSC_STDCALL pcgetoperators_(PC *pc,Mat *mat,Mat *pmat,MatStructure *flag,int *ierr)
232: {
233: CHKFORTRANNULLINTEGER(flag);
234: CHKFORTRANNULLOBJECT(mat);
235: CHKFORTRANNULLOBJECT(pmat)
236: *PCGetOperators(*pc,mat,pmat,flag);
237: }
239: void PETSC_STDCALL pcgetfactoredmatrix_(PC *pc,Mat *mat,int *ierr)
240: {
241: *PCGetFactoredMatrix(*pc,mat);
242: }
243:
244: void PETSC_STDCALL pcsetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
245: int *ierr PETSC_END_LEN(len))
246: {
247: char *t;
249: FIXCHAR(prefix,len,t);
250: *PCSetOptionsPrefix(*pc,t);
251: FREECHAR(prefix,t);
252: }
254: void PETSC_STDCALL pcappendoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
255: int *ierr PETSC_END_LEN(len))
256: {
257: char *t;
259: FIXCHAR(prefix,len,t);
260: *PCAppendOptionsPrefix(*pc,t);
261: FREECHAR(prefix,t);
262: }
264: void PETSC_STDCALL pcdestroy_(PC *pc,int *ierr)
265: {
266: *PCDestroy(*pc);
267: }
269: void PETSC_STDCALL pccreate_(MPI_Comm *comm,PC *newpc,int *ierr)
270: {
271: *PCCreate((MPI_Comm)PetscToPointerComm(*comm),newpc);
272: }
274: void PETSC_STDCALL pcregisterdestroy_(int *ierr)
275: {
276: *PCRegisterDestroy();
277: }
279: void PETSC_STDCALL pcgettype_(PC *pc,CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
280: {
281: char *tname;
283: *PCGetType(*pc,&tname);
284: #if defined(PETSC_USES_CPTOFCD)
285: {
286: char *t = _fcdtocp(name); int len1 = _fcdlen(name);
287: *PetscStrncpy(t,tname,len1); if (*ierr) return;
288: }
289: #else
290: *PetscStrncpy(name,tname,len);if (*ierr) return;
291: #endif
292: }
294: void PETSC_STDCALL pcgetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
295: int *ierr PETSC_END_LEN(len))
296: {
297: char *tname;
299: *PCGetOptionsPrefix(*pc,&tname);
300: #if defined(PETSC_USES_CPTOFCD)
301: {
302: char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
303: *PetscStrncpy(t,tname,len1);if (*ierr) return;
304: }
305: #else
306: *PetscStrncpy(prefix,tname,len);if (*ierr) return;
307: #endif
308: }
310: void PETSC_STDCALL pcasmsetlocalsubdomains_(PC *pc,int *n,IS *is, int *ierr)
311: {
312: CHKFORTRANNULLOBJECT(is);
313: *PCASMSetLocalSubdomains(*pc,*n,is);
314: }
316: void PETSC_STDCALL pcasmsettotalsubdomains_(PC *pc,int *N,IS *is, int *ierr)
317: {
318: CHKFORTRANNULLOBJECT(is);
319: *PCASMSetTotalSubdomains(*pc,*N,is);
320: }
322: void PETSC_STDCALL pcasmgetlocalsubdomains_(PC *pc,int *n,IS **is, int *ierr)
323: {
324: CHKFORTRANNULLOBJECT(is);
325: CHKFORTRANNULLINTEGER(n);
326: *PCASMGetLocalSubdomains(*pc,n,is);
327: }
329: void mgdefaultresidual_(Mat *mat,Vec *b,Vec *x,Vec *r, int *ierr)
330: {
331: *MGDefaultResidual(*mat,*b,*x,*r);
332: }
334: static int ourresidualfunction(Mat mat,Vec b,Vec x,Vec R)
335: {
336: int 0;
337: (*(void (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&b,&x,&R,&ierr);
338: return 0;
339: }
341: void PETSC_STDCALL mgsetresidual_(PC *pc,int *l,int (*residual)(Mat*,Vec*,Vec*,Vec*,int*),Mat *mat, int *ierr)
342: {
343: int (*rr)(Mat,Vec,Vec,Vec);
344: if ((void(*)(void))residual == (void(*)(void))mgdefaultresidual_) rr = MGDefaultResidual;
345: else {
346: if (!((PetscObject)*mat)->fortran_func_pointers) {
347: *PetscMalloc(1*sizeof(void *),&((PetscObject)*mat)->fortran_func_pointers);
348: }
349: ((PetscObject)*mat)->fortran_func_pointers[0] = (void(*)(void))residual;
350: rr = ourresidualfunction;
351: }
352: *MGSetResidual(*pc,*l,rr,*mat);
353: }
355: void PETSC_STDCALL pcilusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), int *ierr PETSC_END_LEN(len)){
356: char *t;
358: FIXCHAR(ordering,len,t);
359: *PCILUSetMatOrdering(*pc,t);
360: FREECHAR(ordering,t);
361: }
363: void PETSC_STDCALL pclusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), int *ierr PETSC_END_LEN(len)){
364: char *t;
366: FIXCHAR(ordering,len,t);
367: *PCLUSetMatOrdering(*pc,t);
368: FREECHAR(ordering,t);
369: }
371: EXTERN_C_END