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