1 #include <petsc/private/ftnimpl.h>
2 #include <petscds.h>
3 #include <petscviewer.h>
4
5 #if defined(PETSC_HAVE_FORTRAN_CAPS)
6 #define petscdssetriemannsolver_ PETSCDSSETRIEMANNSOLVER
7 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
8 #define petscdssetriemannsolver_ petscdssetriemannsolver
9 #endif
10
11 static PetscFortranCallbackId riemannsolver;
12
13 // We can't use PetscObjectUseFortranCallback() because this function returns void
ourriemannsolver(PetscInt dim,PetscInt Nf,const PetscReal x[],const PetscReal n[],const PetscScalar uL[],const PetscScalar uR[],PetscInt numConstants,const PetscScalar constants[],PetscScalar flux[],PetscCtx ctx)14 static void ourriemannsolver(PetscInt dim, PetscInt Nf, const PetscReal x[], const PetscReal n[], const PetscScalar uL[], const PetscScalar uR[], PetscInt numConstants, const PetscScalar constants[], PetscScalar flux[], PetscCtx ctx)
15 {
16 void (*func)(PetscInt *dim, PetscInt *Nf, const PetscReal x[], const PetscReal n[], const PetscScalar uL[], const PetscScalar uR[], const PetscInt *numConstants, const PetscScalar constants[], PetscScalar flux[], PetscCtx ctx);
17 void *_ctx;
18 PetscCallAbort(PETSC_COMM_SELF, PetscObjectGetFortranCallback((PetscObject)ctx, PETSC_FORTRAN_CALLBACK_CLASS, riemannsolver, (PetscFortranCallbackFn **)&func, &_ctx));
19 if (func) (*func)(&dim, &Nf, x, n, uL, uR, &numConstants, constants, flux, _ctx);
20 }
21
petscdssetriemannsolver_(PetscDS * prob,PetscInt * f,void (* rs)(PetscInt *,PetscInt *,PetscReal *,PetscReal *,PetscScalar *,PetscScalar *,PetscInt *,PetscScalar *,PetscScalar *,void *,PetscErrorCode *),PetscErrorCode * ierr)22 PETSC_EXTERN void petscdssetriemannsolver_(PetscDS *prob, PetscInt *f, void (*rs)(PetscInt *, PetscInt *, PetscReal *, PetscReal *, PetscScalar *, PetscScalar *, PetscInt *, PetscScalar *, PetscScalar *, void *, PetscErrorCode *), PetscErrorCode *ierr)
23 {
24 *ierr = PetscObjectSetFortranCallback((PetscObject)*prob, PETSC_FORTRAN_CALLBACK_CLASS, &riemannsolver, (PetscFortranCallbackFn *)rs, NULL);
25 if (*ierr) return;
26 *ierr = PetscDSSetRiemannSolver(*prob, *f, ourriemannsolver);
27 if (*ierr) return;
28 }
29