Actual source code: zfdmatrixf.c

  1: #include <petsc/private/f90impl.h>
  2: #include <petsc/private/matimpl.h>

  4: /* Declare these pointer types instead of void* for clarity, but do not include petscts.h so that this code does have an actual reverse dependency. */
  5: typedef struct _p_TS   *TS;
  6: typedef struct _p_SNES *SNES;

  8: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  9:   #define matfdcoloringsetfunctionts_              MATFDCOLORINGSETFUNCTIONTS
 10:   #define matfdcoloringsetfunction_                MATFDCOLORINGSETFUNCTION
 11:   #define matfdcoloringview_                       MATFDCOLORINGVIEW
 12:   #define matfdcoloingsettype_                     MATFDCOLORINGSETTYPE
 13:   #define matfdcoloringgetperturbedcolumnsf90_     MATFDCOLORINGGETPERTURBEDCOLUMNSF90
 14:   #define matfdcoloringrestoreperturbedcolumnsf90_ MATFDCOLORINGRESTOREPERTURBEDCOLUMNSF90
 15: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 16:   #define matfdcoloringsetfunctionts_              matfdcoloringsetfunctionts
 17:   #define matfdcoloringsetfunction_                matfdcoloringsetfunction
 18:   #define matfdcoloringview_                       matfdcoloringview
 19:   #define matfdcoloingsettype_                     matfdcoloringsettype
 20:   #define matfdcoloringgetperturbedcolumnsf90_     matfdcoloringgetperturbedcolumnsf90
 21:   #define matfdcoloringrestoreperturbedcolumnsf90_ matfdcoloringrestoreperturbedcolumnsf90
 22: #endif

 24: PETSC_EXTERN void matfdcoloringgetperturbedcolumnsf90_(MatFDColoring *x, F90Array1d *ptr, int *__ierr PETSC_F90_2PTR_PROTO(ptrd))
 25: {
 26:   const PetscInt *fa;
 27:   PetscInt        len;

 29:   *__ierr = MatFDColoringGetPerturbedColumns(*x, &len, &fa);
 30:   if (*__ierr) return;
 31:   *__ierr = F90Array1dCreate((void *)fa, MPIU_INT, 1, len, ptr PETSC_F90_2PTR_PARAM(ptrd));
 32: }
 33: PETSC_EXTERN void matfdcoloringrestoreperturbedcolumnsf90_(MatFDColoring *x, F90Array1d *ptr, int *__ierr PETSC_F90_2PTR_PROTO(ptrd))
 34: {
 35:   *__ierr = F90Array1dDestroy(ptr, MPIU_INT PETSC_F90_2PTR_PARAM(ptrd));
 36: }

 38: /* These are not extern C because they are passed into non-extern C user level functions */
 39: static PetscErrorCode ourmatfdcoloringfunctionts(TS ts, PetscReal t, Vec x, Vec y, MatFDColoring fd)
 40: {
 41:   PetscErrorCode ierr = PETSC_SUCCESS;
 42:   (*(void (*)(TS *, PetscReal *, Vec *, Vec *, void *, PetscErrorCode *))fd->ftn_func_pointer)(&ts, &t, &x, &y, fd->ftn_func_cntx, &ierr);
 43:   return ierr;
 44: }

 46: static PetscErrorCode ourmatfdcoloringfunctionsnes(SNES snes, Vec x, Vec y, MatFDColoring fd)
 47: {
 48:   PetscErrorCode ierr = PETSC_SUCCESS;
 49:   (*(void (*)(SNES *, Vec *, Vec *, void *, PetscErrorCode *))fd->ftn_func_pointer)(&snes, &x, &y, fd->ftn_func_cntx, &ierr);
 50:   return ierr;
 51: }

 53: /*
 54:         MatFDColoringSetFunction sticks the Fortran function and its context into the MatFDColoring structure and passes the MatFDColoring object
 55:     in as the function context. ourmafdcoloringfunctionsnes() and ourmatfdcoloringfunctionts()  then access the function and its context from the
 56:     MatFDColoring that is passed in. This is the same way that fortran_func_pointers is used in PETSc objects.

 58:    NOTE: FORTRAN USER CANNOT PUT IN A NEW J OR B currently.
 59: */

 61: PETSC_EXTERN void matfdcoloringsetfunctionts_(MatFDColoring *fd, void (*f)(TS *, double *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
 62: {
 63:   (*fd)->ftn_func_pointer = (void (*)(void))f;
 64:   (*fd)->ftn_func_cntx    = ctx;

 66:   *ierr = MatFDColoringSetFunction(*fd, (PetscErrorCodeFn *)ourmatfdcoloringfunctionts, *fd);
 67: }

 69: PETSC_EXTERN void matfdcoloringsetfunction_(MatFDColoring *fd, void (*f)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
 70: {
 71:   (*fd)->ftn_func_pointer = (void (*)(void))f;
 72:   (*fd)->ftn_func_cntx    = ctx;

 74:   *ierr = MatFDColoringSetFunction(*fd, (PetscErrorCodeFn *)ourmatfdcoloringfunctionsnes, *fd);
 75: }

 77: PETSC_EXTERN void matfdcoloringview_(MatFDColoring *c, PetscViewer *vin, PetscErrorCode *ierr)
 78: {
 79:   PetscViewer v;

 81:   PetscPatchDefaultViewers_Fortran(vin, v);
 82:   *ierr = MatFDColoringView(*c, v);
 83: }

 85: PETSC_EXTERN void matfdcoloringsettype_(MatFDColoring *matfdcoloring, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
 86: {
 87:   char *t;

 89:   FIXCHAR(type, len, t);
 90:   *ierr = MatFDColoringSetType(*matfdcoloring, t);
 91:   if (*ierr) return;
 92:   FREECHAR(type, t);
 93: }