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 matfdcoloringgetperturbedcolumnsf90_     MATFDCOLORINGGETPERTURBEDCOLUMNSF90
     12:   #define matfdcoloringrestoreperturbedcolumnsf90_ MATFDCOLORINGRESTOREPERTURBEDCOLUMNSF90
     13: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     14:   #define matfdcoloringsetfunctionts_              matfdcoloringsetfunctionts
     15:   #define matfdcoloringsetfunction_                matfdcoloringsetfunction
     16:   #define matfdcoloringgetperturbedcolumnsf90_     matfdcoloringgetperturbedcolumnsf90
     17:   #define matfdcoloringrestoreperturbedcolumnsf90_ matfdcoloringrestoreperturbedcolumnsf90
     18: #endif

     20: PETSC_EXTERN void matfdcoloringgetperturbedcolumnsf90_(MatFDColoring *x, F90Array1d *ptr, int *__ierr PETSC_F90_2PTR_PROTO(ptrd))
     21: {
     22:   const PetscInt *fa;
     23:   PetscInt        len;

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

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

     42: static PetscErrorCode ourmatfdcoloringfunctionsnes(SNES snes, Vec x, Vec y, MatFDColoring fd)
     43: {
     44:   PetscErrorCode ierr = PETSC_SUCCESS;
     45:   (*(void (*)(SNES *, Vec *, Vec *, void *, PetscErrorCode *))fd->ftn_func_pointer)(&snes, &x, &y, fd->ftn_func_cntx, &ierr);
     46:   return ierr;
     47: }

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

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

     57: PETSC_EXTERN void matfdcoloringsetfunctionts_(MatFDColoring *fd, void (*f)(TS *, double *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
     58: {
     59:   (*fd)->ftn_func_pointer = (void (*)(void))f;
     60:   (*fd)->ftn_func_cntx    = ctx;

     62:   *ierr = MatFDColoringSetFunction(*fd, (PetscErrorCodeFn *)ourmatfdcoloringfunctionts, *fd);
     63: }

     65: PETSC_EXTERN void matfdcoloringsetfunction_(MatFDColoring *fd, void (*f)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
     66: {
     67:   (*fd)->ftn_func_pointer = (void (*)(void))f;
     68:   (*fd)->ftn_func_cntx    = ctx;

     70:   *ierr = MatFDColoringSetFunction(*fd, (PetscErrorCodeFn *)ourmatfdcoloringfunctionsnes, *fd);
     71: }