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