Actual source code: zpc.c
1: /*$Id: zpc.c,v 1.47 2001/03/28 19:43:08 balay 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: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
40: #define mgdefaultresidual_ mgdefaultresidual
41: #define mgsetresidual_ mgsetresidual
42: #define pcasmsetlocalsubdomains_ pcasmsetlocalsubdomains
43: #define pcasmsetglobalsubdomains_ pcasmsetglobalsubdomains
44: #define pcasmgetlocalsubdomains_ pcasmgetlocalsubdomains
45: #define matnullspacecreate_ matnullspacecreate
46: #define pcnullspaceattach_ pcnullspaceattach
47: #define pcregisterdestroy_ pcregisterdestroy
48: #define pcdestroy_ pcdestroy
49: #define pccreate_ pccreate
50: #define pcgetoperators_ pcgetoperators
51: #define pcgetfactoredmatrix_ pcgetfactoredmatrix
52: #define pcsetoptionsprefix_ pcsetoptionsprefix
53: #define pcappendoptionsprefix_ pcappendoptionsprefix
54: #define pcbjacobigetsubsles_ pcbjacobigetsubsles
55: #define pcasmgetsubsles_ pcasmgetsubsles
56: #define mggetcoarsesolve_ mggetcoarsesolve
57: #define mggetsmoother_ mggetsmoother
58: #define mggetsmootherup_ mggetsmootherup
59: #define mggetsmootherdown_ mggetsmootherdown
60: #define pcshellsetapplyrichardson_ pcshellsetapplyrichardson
61: #define pcshellsetapply_ pcshellsetapply
62: #define pcgettype_ pcgettype
63: #define pcsettype_ pcsettype
64: #define pcgetoptionsprefix_ pcgetoptionsprefix
65: #define pcview_ pcview
66: #define mgsetlevels_ mgsetlevels
67: #define pccompositesettype_ pccompositesettype
68: #define pccompositeaddpc_ pccompositeaddpc
69: #define pccompositegetpc_ pccompositegetpc
70: #define pccompositespecialsetalpha_ pccompositespecialsetalpha
71: #endif
73: EXTERN_C_BEGIN
75: void PETSC_STDCALL pccompositespecialsetalpha_(PC *pc,Scalar *alpha,int *ierr)
76: {
77: *PCCompositeSpecialSetAlpha(*pc,*alpha);
78: }
80: void PETSC_STDCALL pccompositesettype_(PC *pc,PCCompositeType *type,int *ierr)
81: {
82: *PCCompositeSetType(*pc,*type);
83: }
85: void PETSC_STDCALL pccompositeaddpc_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
86: {
87: char *t;
89: FIXCHAR(type,len,t);
90: *PCCompositeAddPC(*pc,t);
91: FREECHAR(type,t);
92: }
94: void PETSC_STDCALL pccompositegetpc_(PC *pc,int *n,PC *subpc,int *ierr)
95: {
96: *PCCompositeGetPC(*pc,*n,subpc);
97: }
99: void PETSC_STDCALL mgsetlevels_(PC *pc,int *levels,MPI_Comm *comms, int *ierr)
100: {
101: MPI_Comm *comm = comms;
102: if (FORTRANNULLOBJECT(comms)) comm = 0;
103: *MGSetLevels(*pc,*levels,comm);
104: }
106: void PETSC_STDCALL pcview_(PC *pc,PetscViewer *viewer, int *ierr)
107: {
108: PetscViewer v;
109: PetscPatchDefaultViewers_Fortran(viewer,v);
110: *PCView(*pc,v);
111: }
113: void PETSC_STDCALL matnullspacecreate_(MPI_Comm *comm,int *has_cnst,int *n,Vec *vecs,MatNullSpace *SP,int *ierr)
114: {
115: *MatNullSpaceCreate((MPI_Comm)PetscToPointerComm(*comm),*has_cnst,*n,vecs,SP);
116: }
118: void PETSC_STDCALL pcnullspaceattach_(PC *pc,MatNullSpace *nullsp,int *ierr)
119: {
120: *PCNullSpaceAttach(*pc,*nullsp);
121: }
123: void PETSC_STDCALL pcsettype_(PC *pc,CHAR type PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
124: {
125: char *t;
127: FIXCHAR(type,len,t);
128: *PCSetType(*pc,t);
129: FREECHAR(type,t);
130: }
133: static void (PETSC_STDCALL *f1)(void *,Vec*,Vec*,int*);
134: static int ourshellapply(void *ctx,Vec x,Vec y)
135: {
136: int 0;
137: (*f1)(ctx,&x,&y,&ierr);
138: return 0;
139: }
141: void PETSC_STDCALL pcshellsetapply_(PC *pc,void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,int*),void *ptr,
142: int *ierr)
143: {
144: f1 = apply;
145: *PCShellSetApply(*pc,ourshellapply,ptr);
146: }
148: static void (PETSC_STDCALL *f9)(void *,int*);
149: static int ourshellsetup(void *ctx)
150: {
151: int 0;
153: (*f9)(ctx,&ierr);
154: return 0;
155: }
157: void PETSC_STDCALL pcshellsetsetup_(PC *pc,void (PETSC_STDCALL *setup)(void*,int*),int *ierr)
158: {
159: f9 = setup;
160: *PCShellSetSetUp(*pc,ourshellsetup);
161: }
163: /* -----------------------------------------------------------------*/
164: static void (PETSC_STDCALL *f2)(void*,Vec*,Vec*,Vec*,int*,int*);
165: static int ourapplyrichardson(void *ctx,Vec x,Vec y,Vec w,int m)
166: {
167: int 0;
169: (*f2)(ctx,&x,&y,&w,&m,&ierr);
170: return 0;
171: }
173: void PETSC_STDCALL pcshellsetapplyrichardson_(PC *pc,
174: void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,Vec *,int*,int*),
175: void *ptr,int *ierr)
176: {
177: f2 = apply;
178: *PCShellSetApplyRichardson(*pc,ourapplyrichardson,ptr);
179: }
181: void PETSC_STDCALL mggetcoarsesolve_(PC *pc,SLES *sles,int *ierr)
182: {
183: *MGGetCoarseSolve(*pc,sles);
184: }
186: void PETSC_STDCALL mggetsmoother_(PC *pc,int *l,SLES *sles,int *ierr)
187: {
188: *MGGetSmoother(*pc,*l,sles);
189: }
191: void PETSC_STDCALL mggetsmootherup_(PC *pc,int *l,SLES *sles,int *ierr)
192: {
193: *MGGetSmootherUp(*pc,*l,sles);
194: }
196: void PETSC_STDCALL mggetsmootherdown_(PC *pc,int *l,SLES *sles,int *ierr)
197: {
198: *MGGetSmootherDown(*pc,*l,sles);
199: }
201: void PETSC_STDCALL pcbjacobigetsubsles_(PC *pc,int *n_local,int *first_local,SLES *sles,int *ierr)
202: {
203: SLES *tsles;
204: int i;
205: if (FORTRANNULLINTEGER(n_local)) n_local = PETSC_NULL;
206: if (FORTRANNULLINTEGER(first_local)) first_local = PETSC_NULL;
207: *PCBJacobiGetSubSLES(*pc,n_local,first_local,&tsles);
208: for (i=0; i<*n_local; i++){
209: sles[i] = tsles[i];
210: }
211: }
213: void PETSC_STDCALL pcasmgetsubsles_(PC *pc,int *n_local,int *first_local,SLES *sles,int *ierr)
214: {
215: SLES *tsles;
216: int i,nloc;
217: if (FORTRANNULLINTEGER(n_local)) n_local = PETSC_NULL;
218: if (FORTRANNULLINTEGER(first_local)) first_local = PETSC_NULL;
219: *PCASMGetSubSLES(*pc,&nloc,first_local,&tsles);
220: if (n_local) *n_local = nloc;
221: for (i=0; i<nloc; i++){
222: sles[i] = tsles[i];
223: }
224: }
226: void PETSC_STDCALL pcgetoperators_(PC *pc,Mat *mat,Mat *pmat,MatStructure *flag,int *ierr)
227: {
228: if (FORTRANNULLINTEGER(flag)) flag = PETSC_NULL;
229: if (FORTRANNULLOBJECT(mat)) mat = PETSC_NULL;
230: if (FORTRANNULLOBJECT(pmat)) pmat = PETSC_NULL;
231: *PCGetOperators(*pc,mat,pmat,flag);
232: }
234: void PETSC_STDCALL pcgetfactoredmatrix_(PC *pc,Mat *mat,int *ierr)
235: {
236: *PCGetFactoredMatrix(*pc,mat);
237: }
238:
239: void PETSC_STDCALL pcsetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
240: int *ierr PETSC_END_LEN(len))
241: {
242: char *t;
244: FIXCHAR(prefix,len,t);
245: *PCSetOptionsPrefix(*pc,t);
246: FREECHAR(prefix,t);
247: }
249: void PETSC_STDCALL pcappendoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
250: int *ierr PETSC_END_LEN(len))
251: {
252: char *t;
254: FIXCHAR(prefix,len,t);
255: *PCAppendOptionsPrefix(*pc,t);
256: FREECHAR(prefix,t);
257: }
259: void PETSC_STDCALL pcdestroy_(PC *pc,int *ierr)
260: {
261: *PCDestroy(*pc);
262: }
264: void PETSC_STDCALL pccreate_(MPI_Comm *comm,PC *newpc,int *ierr)
265: {
266: *PCCreate((MPI_Comm)PetscToPointerComm(*comm),newpc);
267: }
269: void PETSC_STDCALL pcregisterdestroy_(int *ierr)
270: {
271: *PCRegisterDestroy();
272: }
274: void PETSC_STDCALL pcgettype_(PC *pc,CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
275: {
276: char *tname;
278: *PCGetType(*pc,&tname);
279: #if defined(PETSC_USES_CPTOFCD)
280: {
281: char *t = _fcdtocp(name); int len1 = _fcdlen(name);
282: *PetscStrncpy(t,tname,len1); if (*ierr) return;
283: }
284: #else
285: *PetscStrncpy(name,tname,len);if (*ierr) return;
286: #endif
287: }
289: void PETSC_STDCALL pcgetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
290: int *ierr PETSC_END_LEN(len))
291: {
292: char *tname;
294: *PCGetOptionsPrefix(*pc,&tname);
295: #if defined(PETSC_USES_CPTOFCD)
296: {
297: char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
298: *PetscStrncpy(t,tname,len1);if (*ierr) return;
299: }
300: #else
301: *PetscStrncpy(prefix,tname,len);if (*ierr) return;
302: #endif
303: }
305: void PETSC_STDCALL pcasmsetlocalsubdomains_(PC *pc,int *n,IS *is, int *ierr)
306: {
307: if (FORTRANNULLOBJECT(is)) is = PETSC_NULL;
308: *PCASMSetLocalSubdomains(*pc,*n,is);
309: }
311: void PETSC_STDCALL pcasmsettotalsubdomains_(PC *pc,int *N,IS *is, int *ierr)
312: {
313: if (FORTRANNULLOBJECT(is)) is = PETSC_NULL;
314: *PCASMSetTotalSubdomains(*pc,*N,is);
315: }
317: void PETSC_STDCALL pcasmgetlocalsubdomains_(PC *pc,int *n,IS **is, int *ierr)
318: {
319: if (FORTRANNULLOBJECT(is)) is = PETSC_NULL;
320: if (FORTRANNULLINTEGER(n)) n = PETSC_NULL;
321: *PCASMGetLocalSubdomains(*pc,n,is);
322: }
324: void PETSC_STDCALL mgdefaultresidual_(Mat *mat,Vec *b,Vec *x,Vec *r, int *ierr)
325: {
326: *MGDefaultResidual(*mat,*b,*x,*r);
327: }
329: static int ourresidualfunction(Mat mat,Vec b,Vec x,Vec R)
330: {
331: int 0;
332: (*(void (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&b,&x,&R,&ierr);
333: return 0;
334: }
336: void PETSC_STDCALL mgsetresidual_(PC *pc,int *l,int (*residual)(Mat*,Vec*,Vec*,Vec*,int*),Mat *mat, int *ierr)
337: {
338: int (*rr)(Mat,Vec,Vec,Vec);
339: if ((void(*)())residual == (void(*)())mgdefaultresidual_) rr = MGDefaultResidual;
340: else {
341: if (!((PetscObject)*mat)->fortran_func_pointers) {
342: *PetscMalloc(1*sizeof(void *),&((PetscObject)*mat)->fortran_func_pointers);
343: }
344: ((PetscObject)*mat)->fortran_func_pointers[0] = (void(*)())residual;
345: rr = ourresidualfunction;
346: }
347: *MGSetResidual(*pc,*l,rr,*mat);
348: }
349: EXTERN_C_END