Actual source code: zpc.c

 2:  #include src/fortran/custom/zpetsc.h
 3:  #include petscksp.h
 4:  #include petscmg.h

  6: #ifdef PETSC_HAVE_FORTRAN_CAPS
  7: #define pcmgdefaultresidual_       PCMGDEFAULTRESIDUAL
  8: #define pcmgsetresidual_           PCMGSETRESIDUAL
  9: #define pcasmsetlocalsubdomains_   PCASMSETLOCALSUBDOMAINS
 10: #define pcasmsetglobalsubdomains_  PCASMSETGLOBALSUBDOMAINS
 11: #define pcasmgetlocalsubmatrices_  PCASMGETLOCALSUBMATRICES
 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 pcbjacobigetsubksp_        PCBJACOBIGETSUBKSP
 21: #define pcasmgetsubksp_            PCASMGETSUBKSP
 22: #define pcmggetcoarsesolve_        PCMGGETCOARSESOLVE
 23: #define pcmggetsmoother_           PCMGGETSMOOTHER
 24: #define pcmggetsmootherup_         PCMGGETSMOOTHERUP
 25: #define pcmggetsmootherdown_       PCMGGETSMOOTHERDOWN
 26: #define pcshellsetapply_           PCSHELLSETAPPLY
 27: #define pcshellsetapplytranspose_  PCSHELLSETAPPLYTRANSPOSE
 28: #define pcshellsetapplyrichardson_ PCSHELLSETAPPLYRICHARDSON
 29: #define pcgettype_                 PCGETTYPE
 30: #define pcsettype_                 PCSETTYPE
 31: #define pcgetoptionsprefix_        PCGETOPTIONSPREFIX
 32: #define matnullspacecreate_        MATNULLSPACECREATE
 33: #define pcview_                    PCVIEW
 34: #define pcmgsetlevels_             PCMGSETLEVELS
 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 pcmgdefaultresidual_       pcmgdefaultresidual
 44: #define pcmgsetresidual_           pcmgsetresidual
 45: #define pcasmsetlocalsubdomains_   pcasmsetlocalsubdomains
 46: #define pcasmsetglobalsubdomains_  pcasmsetglobalsubdomains
 47: #define pcasmgetlocalsubmatrices_  pcasmgetlocalsubmatrices
 48: #define pcasmgetlocalsubdomains_   pcasmgetlocalsubdomains
 49: #define matnullspacecreate_        matnullspacecreate
 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 pcbjacobigetsubksp_        pcbjacobigetsubksp
 58: #define pcasmgetsubksp_            pcasmgetsubksp
 59: #define pcmggetcoarsesolve_        pcmggetcoarsesolve
 60: #define pcmggetsmoother_           pcmggetsmoother
 61: #define pcmggetsmootherup_         pcmggetsmootherup
 62: #define pcmggetsmootherdown_       pcmggetsmootherdown
 63: #define pcshellsetapplyrichardson_ pcshellsetapplyrichardson
 64: #define pcshellsetapply_           pcshellsetapply
 65: #define pcshellsetapplytranspose_  pcshellsetapplytranspose
 66: #define pcgettype_                 pcgettype
 67: #define pcsettype_                 pcsettype
 68: #define pcgetoptionsprefix_        pcgetoptionsprefix
 69: #define pcview_                    pcview
 70: #define pcmgsetlevels_             pcmgsetlevels
 71: #define pccompositesettype_        pccompositesettype
 72: #define pccompositeaddpc_          pccompositeaddpc
 73: #define pccompositegetpc_          pccompositegetpc
 74: #define pccompositespecialsetalpha_  pccompositespecialsetalpha
 75: #define pcshellsetsetup_           pcshellsetsetup
 76: #define pcilusetmatordering_       pcilusetmatordering
 77: #define pclusetmatordering_        pclusetmatordering
 78: #endif

 81: static void (PETSC_STDCALL *f2)(void*,Vec*,Vec*,Vec*,PetscReal*,PetscReal*,PetscReal*,PetscInt*,PetscErrorCode*);
 82: static void (PETSC_STDCALL *f1)(void*,Vec*,Vec*,PetscErrorCode*);
 83: static void (PETSC_STDCALL *f3)(void*,Vec*,Vec*,PetscErrorCode*);
 84: static void (PETSC_STDCALL *f9)(void*,PetscErrorCode*);

 88: static PetscErrorCode ourapplyrichardson(void *ctx,Vec x,Vec y,Vec w,PetscReal rtol,PetscReal abstol,PetscReal dtol,PetscInt m)
 89: {
 90:   PetscErrorCode 0;

 92:   (*f2)(ctx,&x,&y,&w,&rtol,&abstol,&dtol,&m,&ierr);
 93:   return 0;
 94: }

 96: static PetscErrorCode ourshellapply(void *ctx,Vec x,Vec y)
 97: {
 98:   PetscErrorCode 0;
 99:   (*f1)(ctx,&x,&y,&ierr);
100:   return 0;
101: }

103: static PetscErrorCode ourshellapplytranspose(void *ctx,Vec x,Vec y)
104: {
105:   PetscErrorCode 0;
106:   (*f3)(ctx,&x,&y,&ierr);
107:   return 0;
108: }

110: static PetscErrorCode ourshellsetup(void *ctx)
111: {
112:   PetscErrorCode 0;

114:   (*f9)(ctx,&ierr);
115:   return 0;
116: }

118: typedef PetscErrorCode (*MVVVV)(Mat,Vec,Vec,Vec);
119: static PetscErrorCode ourresidualfunction(Mat mat,Vec b,Vec x,Vec R)
120: {
121:   PetscErrorCode 0;
122:   (*(void (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&b,&x,&R,&ierr);
123:   return 0;
124: }

127: void PETSC_STDCALL pccompositespecialsetalpha_(PC *pc,PetscScalar *alpha,PetscErrorCode *ierr)
128: {
129:   *PCCompositeSpecialSetAlpha(*pc,*alpha);
130: }

132: void PETSC_STDCALL pccompositesettype_(PC *pc,PCCompositeType *type,PetscErrorCode *ierr)
133: {
134:   *PCCompositeSetType(*pc,*type);
135: }

137: void PETSC_STDCALL pccompositeaddpc_(PC *pc,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
138: {
139:   char *t;

141:   FIXCHAR(type,len,t);
142:   *PCCompositeAddPC(*pc,t);
143:   FREECHAR(type,t);
144: }

146: void PETSC_STDCALL pccompositegetpc_(PC *pc,PetscInt *n,PC *subpc,PetscErrorCode *ierr)
147: {
148:   *PCCompositeGetPC(*pc,*n,subpc);
149: }

151: void PETSC_STDCALL pcmgsetlevels_(PC *pc,PetscInt *levels,MPI_Comm *comms, PetscErrorCode *ierr)
152: {
153:   CHKFORTRANNULLINTEGER(comms);
154:   *PCMGSetLevels(*pc,*levels,comms);
155: }

157: void PETSC_STDCALL pcview_(PC *pc,PetscViewer *viewer, PetscErrorCode *ierr)
158: {
159:   PetscViewer v;
160:   PetscPatchDefaultViewers_Fortran(viewer,v);
161:   *PCView(*pc,v);
162: }

164: void PETSC_STDCALL matnullspacecreate_(MPI_Comm *comm,PetscTruth *has_cnst,PetscInt *n,Vec *vecs,MatNullSpace *SP,PetscErrorCode *ierr)
165: {
166:   *MatNullSpaceCreate((MPI_Comm)PetscToPointerComm(*comm),*has_cnst,*n,vecs,SP);
167: }

169: void PETSC_STDCALL pcsettype_(PC *pc,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
170: {
171:   char *t;

173:   FIXCHAR(type,len,t);
174:   *PCSetType(*pc,t);
175:   FREECHAR(type,t);
176: }


179: void PETSC_STDCALL pcshellsetapply_(PC *pc,void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,PetscErrorCode*),
180:                                     PetscErrorCode *ierr)
181: {
182:   f1 = apply;
183:   *PCShellSetApply(*pc,ourshellapply);
184: }

186: void PETSC_STDCALL pcshellsetapplytranspose_(PC *pc,void (PETSC_STDCALL *applytranspose)(void*,Vec *,Vec *,PetscErrorCode*),
187:                                              PetscErrorCode *ierr)
188: {
189:   f3 = applytranspose;
190:   *PCShellSetApplyTranspose(*pc,ourshellapplytranspose);
191: }


194: void PETSC_STDCALL pcshellsetsetup_(PC *pc,void (PETSC_STDCALL *setup)(void*,PetscErrorCode*),PetscErrorCode *ierr)
195: {
196:   f9 = setup;
197:   *PCShellSetSetUp(*pc,ourshellsetup);
198: }

200: /* -----------------------------------------------------------------*/

202: void PETSC_STDCALL pcshellsetapplyrichardson_(PC *pc,
203:          void (PETSC_STDCALL *apply)(void*,Vec *,Vec *,Vec *,PetscReal*,PetscReal*,PetscReal*,PetscInt*,PetscErrorCode*),
204:          PetscErrorCode *ierr)
205: {
206:   f2 = apply;
207:   *PCShellSetApplyRichardson(*pc,ourapplyrichardson);
208: }

210: void PETSC_STDCALL pcmggetcoarsesolve_(PC *pc,KSP *ksp,PetscErrorCode *ierr)
211: {
212:   *PCMGGetCoarseSolve(*pc,ksp);
213: }

215: void PETSC_STDCALL pcmggetsmoother_(PC *pc,PetscInt *l,KSP *ksp,PetscErrorCode *ierr)
216: {
217:   *PCMGGetSmoother(*pc,*l,ksp);
218: }

220: void PETSC_STDCALL pcmggetsmootherup_(PC *pc,PetscInt *l,KSP *ksp,PetscErrorCode *ierr)
221: {
222:   *PCMGGetSmootherUp(*pc,*l,ksp);
223: }

225: void PETSC_STDCALL pcmggetsmootherdown_(PC *pc,PetscInt *l,KSP *ksp,PetscErrorCode *ierr)
226: {
227:   *PCMGGetSmootherDown(*pc,*l,ksp);
228: }

230: void PETSC_STDCALL pcbjacobigetsubksp_(PC *pc,PetscInt *n_local,PetscInt *first_local,KSP *ksp,PetscErrorCode *ierr)
231: {
232:   KSP *tksp;
233:   PetscInt  i,nloc;
234:   CHKFORTRANNULLINTEGER(n_local);
235:   CHKFORTRANNULLINTEGER(first_local);
236:   *PCBJacobiGetSubKSP(*pc,&nloc,first_local,&tksp);
237:   if (n_local) *n_local = nloc;
238:   for (i=0; i<nloc; i++){
239:     ksp[i] = tksp[i];
240:   }
241: }

243: void PETSC_STDCALL pcasmgetsubksp_(PC *pc,PetscInt *n_local,PetscInt *first_local,KSP *ksp,PetscErrorCode *ierr)
244: {
245:   KSP *tksp;
246:   PetscInt  i,nloc;
247:   CHKFORTRANNULLINTEGER(n_local);
248:   CHKFORTRANNULLINTEGER(first_local);
249:   *PCASMGetSubKSP(*pc,&nloc,first_local,&tksp);
250:   if (n_local) *n_local = nloc;
251:   for (i=0; i<nloc; i++){
252:     ksp[i] = tksp[i];
253:   }
254: }

256: void PETSC_STDCALL pcgetoperators_(PC *pc,Mat *mat,Mat *pmat,MatStructure *flag,PetscErrorCode *ierr)
257: {
258:   CHKFORTRANNULLOBJECT(mat);
259:   CHKFORTRANNULLOBJECT(pmat)
260:   *PCGetOperators(*pc,mat,pmat,flag);
261: }

263: void PETSC_STDCALL pcgetfactoredmatrix_(PC *pc,Mat *mat,PetscErrorCode *ierr)
264: {
265:   *PCGetFactoredMatrix(*pc,mat);
266: }
267: 
268: void PETSC_STDCALL pcsetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
269:                                        PetscErrorCode *ierr PETSC_END_LEN(len))
270: {
271:   char *t;

273:   FIXCHAR(prefix,len,t);
274:   *PCSetOptionsPrefix(*pc,t);
275:   FREECHAR(prefix,t);
276: }

278: void PETSC_STDCALL pcappendoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
279:                                           PetscErrorCode *ierr PETSC_END_LEN(len))
280: {
281:   char *t;

283:   FIXCHAR(prefix,len,t);
284:   *PCAppendOptionsPrefix(*pc,t);
285:   FREECHAR(prefix,t);
286: }

288: void PETSC_STDCALL pcdestroy_(PC *pc,PetscErrorCode *ierr)
289: {
290:   *PCDestroy(*pc);
291: }

293: void PETSC_STDCALL pccreate_(MPI_Comm *comm,PC *newpc,PetscErrorCode *ierr)
294: {
295:   *PCCreate((MPI_Comm)PetscToPointerComm(*comm),newpc);
296: }

298: void PETSC_STDCALL pcregisterdestroy_(PetscErrorCode *ierr)
299: {
300:   *PCRegisterDestroy();
301: }

303: void PETSC_STDCALL pcgettype_(PC *pc,CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
304: {
305:   const char *tname;

307:   *PCGetType(*pc,&tname);
308: #if defined(PETSC_USES_CPTOFCD)
309:   {
310:   char *t = _fcdtocp(name); int len1 = _fcdlen(name);
311:   *PetscStrncpy(t,tname,len1); if (*ierr) return;
312:   }
313: #else
314:   *PetscStrncpy(name,tname,len);if (*ierr) return;
315: #endif
316:   FIXRETURNCHAR(name,len);

318: }

320: void PETSC_STDCALL pcgetoptionsprefix_(PC *pc,CHAR prefix PETSC_MIXED_LEN(len),
321:                                        PetscErrorCode *ierr PETSC_END_LEN(len))
322: {
323:   const char *tname;

325:   *PCGetOptionsPrefix(*pc,&tname);
326: #if defined(PETSC_USES_CPTOFCD)
327:   {
328:     char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
329:     *PetscStrncpy(t,tname,len1);if (*ierr) return;
330:   }
331: #else
332:   *PetscStrncpy(prefix,tname,len);if (*ierr) return;
333: #endif
334: }

336: void PETSC_STDCALL pcasmsetlocalsubdomains_(PC *pc,PetscInt *n,IS *is, PetscErrorCode *ierr)
337: {
338:   CHKFORTRANNULLOBJECT(is);
339:   *PCASMSetLocalSubdomains(*pc,*n,is);
340: }

342: void PETSC_STDCALL pcasmsettotalsubdomains_(PC *pc,PetscInt *N,IS *is, PetscErrorCode *ierr)
343: {
344:   CHKFORTRANNULLOBJECT(is);
345:   *PCASMSetTotalSubdomains(*pc,*N,is);
346: }

348: void PETSC_STDCALL pcasmgetlocalsubmatrices_(PC *pc,PetscInt *n,Mat *mat, PetscErrorCode *ierr)
349: {
350:   PetscInt nloc,i;
351:   Mat  *tmat;
352:   CHKFORTRANNULLOBJECT(mat);
353:   CHKFORTRANNULLINTEGER(n);
354:   *PCASMGetLocalSubmatrices(*pc,&nloc,&tmat);
355:   if (n) *n = nloc;
356:   if (mat) {
357:     for (i=0; i<nloc; i++){
358:       mat[i] = tmat[i];
359:     }
360:   }
361: }
362: void PETSC_STDCALL pcasmgetlocalsubdomains_(PC *pc,PetscInt *n,IS *is, PetscErrorCode *ierr)
363: {
364:   PetscInt nloc,i;
365:   IS  *tis;
366:   CHKFORTRANNULLOBJECT(is);
367:   CHKFORTRANNULLINTEGER(n);
368:   *PCASMGetLocalSubdomains(*pc,&nloc,&tis);
369:   if (n) *n = nloc;
370:   if (is) {
371:     for (i=0; i<nloc; i++){
372:       is[i] = tis[i];
373:     }
374:   }
375: }

377: void pcmgdefaultresidual_(Mat *mat,Vec *b,Vec *x,Vec *r, PetscErrorCode *ierr)
378: {
379:   *PCMGDefaultResidual(*mat,*b,*x,*r);
380: }

382: void PETSC_STDCALL pcmgsetresidual_(PC *pc,PetscInt *l,PetscErrorCode (*residual)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*),Mat *mat, PetscErrorCode *ierr)
383: {
384:   MVVVV rr;
385:   if ((FCNVOID)residual == (FCNVOID)pcmgdefaultresidual_) rr = PCMGDefaultResidual;
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] = (FCNVOID)residual;
391:     rr = ourresidualfunction;
392:   }
393:   *PCMGSetResidual(*pc,*l,rr,*mat);
394: }

396: void PETSC_STDCALL pcilusetmatordering_(PC *pc,CHAR ordering PETSC_MIXED_LEN(len), PetscErrorCode *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), PetscErrorCode *ierr PETSC_END_LEN(len)){
405:   char *t;

407:     FIXCHAR(ordering,len,t);
408:     *PCLUSetMatOrdering(*pc,t);
409:     FREECHAR(ordering,t);
410: }

413: #ifdef PETSC_HAVE_FORTRAN_CAPS
414: #define pchypresettype_ PCHYPRESETTYPE
415: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) && !defined(FORTRANDOUBLEUNDERSCORE)
416: #define pchypresettype_ pchypresettype
417: #endif

419: #if defined(PETSC_HAVE_HYPRE) && !defined(PETSC_USE_COMPLEX)

421: #if defined(__cplusplus)
423: #endif
424: void PETSC_STDCALL  pchypresettype_(PC *pc, CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len) )
425: {
426:   char *t;
427:   FIXCHAR(name,len,t);
428:   *PCHYPRESetType(*pc,t);
429:   FREECHAR(name,t);
430: }
431: #if defined(__cplusplus)
432: }
433: #endif

435: #endif