1 #include <petsc/private/f90impl.h> 2 #include <petsc/private/matimpl.h> 3 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; 7 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 23 24 PETSC_EXTERN void matfdcoloringgetperturbedcolumnsf90_(MatFDColoring *x, F90Array1d *ptr, int *__ierr PETSC_F90_2PTR_PROTO(ptrd)) 25 { 26 const PetscInt *fa; 27 PetscInt len; 28 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 } 37 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 } 45 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 } 52 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. 57 58 NOTE: FORTRAN USER CANNOT PUT IN A NEW J OR B currently. 59 */ 60 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; 65 66 *ierr = MatFDColoringSetFunction(*fd, (PetscErrorCodeFunction)ourmatfdcoloringfunctionts, *fd); 67 } 68 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; 73 74 *ierr = MatFDColoringSetFunction(*fd, (PetscErrorCodeFunction)ourmatfdcoloringfunctionsnes, *fd); 75 } 76 77 PETSC_EXTERN void matfdcoloringview_(MatFDColoring *c, PetscViewer *vin, PetscErrorCode *ierr) 78 { 79 PetscViewer v; 80 81 PetscPatchDefaultViewers_Fortran(vin, v); 82 *ierr = MatFDColoringView(*c, v); 83 } 84 85 PETSC_EXTERN void matfdcoloringsettype_(MatFDColoring *matfdcoloring, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 86 { 87 char *t; 88 89 FIXCHAR(type, len, t); 90 *ierr = MatFDColoringSetType(*matfdcoloring, t); 91 if (*ierr) return; 92 FREECHAR(type, t); 93 } 94