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: }