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