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