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