Actual source code: zsles.c

     2:  #include src/fortran/custom/zpetsc.h
     3:  #include petscksp.h
     4:  #include petscda.h
     5:  #include petscdmmg.h

      7: #ifdef PETSC_HAVE_FORTRAN_CAPS
      8: #define dmmgcreate_              DMMGCREATE
      9: #define dmmgdestroy_             DMMGDESTROY
     10: #define dmmgsetup_               DMMGSETUP
     11: #define dmmgsetdm_               DMMGSETDM
     12: #define dmmgview_                DMMGVIEW
     13: #define dmmgsolve_               DMMGSOLVE
     14: #define dmmggetda_               DMMGGETDA
     15: #define dmmgsetksp_              DMMGSETKSP
     16: #define dmmggetx_                DMMGGETX
     17: #define dmmggetj_                DMMGGETJ
     18: #define dmmggetb_                DMMGGETB
     19: #define dmmggetrhs_              DMMGGETRHS
     20: #define dmmggetksp_              DMMGGETKSP
     21: #define dmmggetlevels_           DMMGGETLEVELS
     22: #define dmmgsetinitialguess_     DMMGSETINITIALGUESS
     23: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     24: #define dmmggetrhs_              dmmggetrhs
     25: #define dmmggetx_                dmmggetx
     26: #define dmmggetj_                dmmggetj
     27: #define dmmggetb_                dmmggetb
     28: #define dmmggetksp_              dmmggetksp
     29: #define dmmggetda_               dmmggetda
     30: #define dmmggetlevels_           dmmggetlevels
     31: #define dmmgsetksp_              dmmgsetksp
     32: #define dmmgdestroy_             dmmgdestroy
     33: #define dmmgcreate_              dmmgcreate
     34: #define dmmgsetup_               dmmgsetup
     35: #define dmmgsetdm_               dmmgsetdm
     36: #define dmmgview_                dmmgview
     37: #define dmmgsolve_               dmmgsolve
     38: #define dmmgsetinitialguess_     dmmgsetinitialguess
     39: #endif

     42: static void (PETSC_STDCALL *theirmat)(DMMG*,Mat*,PetscErrorCode*);

     45: static PetscErrorCode ourrhs(DMMG dmmg,Vec vec)
     46: {
     47:   PetscErrorCode 0;
     48:   (*(void (PETSC_STDCALL *)(DMMG*,Vec*,PetscErrorCode*))(((PetscObject)dmmg->dm)->fortran_func_pointers[0]))(&dmmg,&vec,&ierr);
     49:   return ierr;
     50: }

     52: static PetscErrorCode ourinitialguess(DMMG dmmg,Vec vec)
     53: {
     54:   PetscErrorCode 0;
     55:   (*(void (PETSC_STDCALL *)(DMMG*,Vec*,PetscErrorCode*))(((PetscObject)dmmg->dm)->fortran_func_pointers[1]))(&dmmg,&vec,&ierr);
     56:   return ierr;
     57: }

     59: /*
     60:    Since DMMGSetKSP() immediately calls the matrix functions for each level we do not need to store
     61:   the mat() function inside the DMMG object
     62: */
     63: static PetscErrorCode ourmat(DMMG dmmg,Mat mat)
     64: {
     65:   PetscErrorCode 0;
     66:   (*theirmat)(&dmmg,&mat,&ierr);
     67:   return ierr;
     68: }

     72: void PETSC_STDCALL dmmggetx_(DMMG **dmmg,Vec *x,PetscErrorCode *ierr)
     73: {
     74:   *0;
     75:   *x    = DMMGGetx(*dmmg);
     76: }

     78: void PETSC_STDCALL dmmggetj_(DMMG **dmmg,Mat *x,PetscErrorCode *ierr)
     79: {
     80:   *0;
     81:   *x    = DMMGGetJ(*dmmg);
     82: }

     84: void PETSC_STDCALL dmmggetb_(DMMG **dmmg,Mat *x,PetscErrorCode *ierr)
     85: {
     86:   *0;
     87:   *x    = DMMGGetB(*dmmg);
     88: }

     90: void PETSC_STDCALL dmmggetrhs_(DMMG **dmmg,Vec *x,PetscErrorCode *ierr)
     91: {
     92:   *0;
     93:   *x    = DMMGGetRHS(*dmmg);
     94: }

     96: void PETSC_STDCALL dmmggetksp_(DMMG **dmmg,KSP *x,PetscErrorCode *ierr)
     97: {
     98:   *0;
     99:   *x    = DMMGGetKSP(*dmmg);
    100: }

    102: void PETSC_STDCALL dmmggetlevels_(DMMG **dmmg,PetscInt *x,PetscErrorCode *ierr)
    103: {
    104:   *0;
    105:   *x    = DMMGGetLevels(*dmmg);
    106: }

    108: /* ----------------------------------------------------------------------------------------------------------*/
    109: void PETSC_STDCALL dmmgsetinitialguess_(DMMG **dmmg,void (PETSC_STDCALL *initialguess)(DMMG*,Vec*,PetscErrorCode*),PetscErrorCode *ierr)
    110: {
    111:   PetscInt i;

    113:   *DMMGSetInitialGuess(*dmmg,ourinitialguess);
    114:   /*
    115:     Save the fortran initial guess function in the DM on each level; ourinitialguess() pulls it out when needed
    116:   */
    117:   for (i=0; i<(**dmmg)->nlevels; i++) {
    118:     ((PetscObject)(*dmmg)[i]->dm)->fortran_func_pointers[1] = (FCNVOID)initialguess;
    119:   }
    120: }

    122: void PETSC_STDCALL dmmgsetksp_(DMMG **dmmg,void (PETSC_STDCALL *rhs)(DMMG*,Vec*,PetscErrorCode*),void (PETSC_STDCALL *mat)(DMMG*,Mat*,PetscErrorCode*),PetscErrorCode *ierr)
    123: {
    124:   PetscInt i;
    125:   theirmat = mat;
    126:   *DMMGSetKSP(*dmmg,ourrhs,ourmat);
    127:   /*
    128:     Save the fortran rhs function in the DM on each level; ourrhs() pulls it out when needed
    129:   */
    130:   for (i=0; i<(**dmmg)->nlevels; i++) {
    131:     ((PetscObject)(*dmmg)[i]->dm)->fortran_func_pointers[0] = (FCNVOID)rhs;
    132:   }
    133: }

    135: /* ----------------------------------------------------------------------------------------------------------*/

    137: void PETSC_STDCALL dmmggetda_(DMMG *dmmg,DA *da,PetscErrorCode *ierr)
    138: {
    139:   *da   = (DA)(*dmmg)->dm;
    140:   *0;
    141: }

    143: void PETSC_STDCALL dmmgsetdm_(DMMG **dmmg,DM *dm,PetscErrorCode *ierr)
    144: {
    145:   PetscInt i;
    146:   *DMMGSetDM(*dmmg,*dm);if (*ierr) return;
    147:   /* loop over the levels added a place to hang the function pointers in the DM for each level*/
    148:   for (i=0; i<(**dmmg)->nlevels; i++) {
    149:     *PetscMalloc(4*sizeof(FCNVOID),&((PetscObject)(*dmmg)[i]->dm)->fortran_func_pointers);if (*ierr) return;
    150:   }
    151: }

    153: void PETSC_STDCALL dmmgview_(DMMG **dmmg,PetscViewer *viewer,PetscErrorCode *ierr)
    154: {
    155:   *DMMGView(*dmmg,*viewer);
    156: }

    158: void PETSC_STDCALL dmmgsolve_(DMMG **dmmg,PetscErrorCode *ierr)
    159: {
    160:   *DMMGSolve(*dmmg);
    161: }

    163: void PETSC_STDCALL dmmgcreate_(MPI_Comm *comm,PetscInt *nlevels,void *user,DMMG **dmmg,PetscErrorCode *ierr)
    164: {
    165:   *DMMGCreate((MPI_Comm)PetscToPointerComm(*comm),*nlevels,user,dmmg);
    166: }

    168: void PETSC_STDCALL dmmgdestroy_(DMMG **dmmg,PetscErrorCode *ierr)
    169: {
    170:   *DMMGDestroy(*dmmg);
    171: }

    173: void PETSC_STDCALL dmmgsetup_(DMMG **dmmg,PetscErrorCode *ierr)
    174: {
    175:   *DMMGSetUp(*dmmg);
    176: }