1 #include <petsc/private/ftnimpl.h>
2 #include <petsc/private/dmdaimpl.h>
3 #include <petsc/private/snesimpl.h>
4 #if defined(PETSC_HAVE_FORTRAN_CAPS)
5 #define dmdasnessetjacobianlocal_ DMDASNESSETJACOBIANLOCAL
6 #define dmdasnessetfunctionlocal_ DMDASNESSETFUNCTIONLOCAL
7 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
8 #define dmdasnessetjacobianlocal_ dmdasnessetjacobianlocal
9 #define dmdasnessetfunctionlocal_ dmdasnessetfunctionlocal
10 #endif
11
12 static struct {
13 PetscFortranCallbackId lf1d;
14 PetscFortranCallbackId lf2d;
15 PetscFortranCallbackId lf3d;
16 PetscFortranCallbackId lj1d;
17 PetscFortranCallbackId lj2d;
18 PetscFortranCallbackId lj3d;
19 } _cb;
20
21 /************************************************/
sourlj1d(DMDALocalInfo * info,PetscScalar * in,Mat A,Mat m,void * ptr)22 static PetscErrorCode sourlj1d(DMDALocalInfo *info, PetscScalar *in, Mat A, Mat m, void *ptr)
23 {
24 void (*func)(DMDALocalInfo *, PetscScalar *, Mat *, Mat *, void *, PetscErrorCode *), *ctx;
25 DMSNES sdm;
26
27 PetscFunctionBegin;
28 PetscCall(DMGetDMSNES(info->da, &sdm));
29 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj1d, (PetscFortranCallbackFn **)&func, &ctx));
30 PetscCallFortranVoidFunction((*func)(info, &in[info->dof * info->gxs], &A, &m, ctx, &ierr));
31 PetscFunctionReturn(PETSC_SUCCESS);
32 }
33
sourlj2d(DMDALocalInfo * info,PetscScalar ** in,Mat A,Mat m,void * ptr)34 static PetscErrorCode sourlj2d(DMDALocalInfo *info, PetscScalar **in, Mat A, Mat m, void *ptr)
35 {
36 void (*func)(DMDALocalInfo *, PetscScalar *, Mat *, Mat *, void *, PetscErrorCode *), *ctx;
37 DMSNES sdm;
38
39 PetscFunctionBegin;
40 PetscCall(DMGetDMSNES(info->da, &sdm));
41 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj2d, (PetscFortranCallbackFn **)&func, &ctx));
42 PetscCallFortranVoidFunction((*func)(info, &in[info->gys][info->dof * info->gxs], &A, &m, ctx, &ierr));
43 PetscFunctionReturn(PETSC_SUCCESS);
44 }
45
sourlj3d(DMDALocalInfo * info,PetscScalar *** in,Mat A,Mat m,void * ptr)46 static PetscErrorCode sourlj3d(DMDALocalInfo *info, PetscScalar ***in, Mat A, Mat m, void *ptr)
47 {
48 void (*func)(DMDALocalInfo *, PetscScalar *, Mat *, Mat *, void *, PetscErrorCode *), *ctx;
49 DMSNES sdm;
50
51 PetscFunctionBegin;
52 PetscCall(DMGetDMSNES(info->da, &sdm));
53 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj2d, (PetscFortranCallbackFn **)&func, &ctx));
54 PetscCallFortranVoidFunction((*func)(info, &in[info->gzs][info->gys][info->dof * info->gxs], &A, &m, ctx, &ierr));
55 PetscFunctionReturn(PETSC_SUCCESS);
56 }
57
dmdasnessetjacobianlocal_(DM * da,void (* jac)(DMDALocalInfo *,void *,void *,void *,void *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)58 PETSC_EXTERN void dmdasnessetjacobianlocal_(DM *da, void (*jac)(DMDALocalInfo *, void *, void *, void *, void *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr)
59 {
60 DMSNES sdm;
61 PetscInt dim;
62
63 *ierr = DMGetDMSNESWrite(*da, &sdm);
64 if (*ierr) return;
65 *ierr = DMDAGetInfo(*da, &dim, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL);
66 if (*ierr) return;
67 if (dim == 2) {
68 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lj2d, (PetscFortranCallbackFn *)jac, ctx);
69 if (*ierr) return;
70 *ierr = DMDASNESSetJacobianLocal(*da, (PetscErrorCode (*)(DMDALocalInfo *, void *, Mat, Mat, void *))sourlj2d, NULL);
71 } else if (dim == 3) {
72 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lj3d, (PetscFortranCallbackFn *)jac, ctx);
73 if (*ierr) return;
74 *ierr = DMDASNESSetJacobianLocal(*da, (PetscErrorCode (*)(DMDALocalInfo *, void *, Mat, Mat, void *))sourlj3d, NULL);
75 } else if (dim == 1) {
76 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lj1d, (PetscFortranCallbackFn *)jac, ctx);
77 if (*ierr) return;
78 *ierr = DMDASNESSetJacobianLocal(*da, (PetscErrorCode (*)(DMDALocalInfo *, void *, Mat, Mat, void *))sourlj1d, NULL);
79 } else *ierr = PETSC_ERR_ARG_OUTOFRANGE;
80 }
81
82 /************************************************/
83
sourlf1d(DMDALocalInfo * info,PetscScalar * in,PetscScalar * out,void * ptr)84 static PetscErrorCode sourlf1d(DMDALocalInfo *info, PetscScalar *in, PetscScalar *out, void *ptr)
85 {
86 void (*func)(DMDALocalInfo *, PetscScalar *, PetscScalar *, void *, PetscErrorCode *), *ctx;
87 DMSNES sdm;
88
89 PetscFunctionBegin;
90 PetscCall(DMGetDMSNES(info->da, &sdm));
91 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf1d, (PetscFortranCallbackFn **)&func, &ctx));
92 PetscCallFortranVoidFunction((*func)(info, &in[info->dof * info->gxs], &out[info->dof * info->xs], ctx, &ierr));
93 PetscFunctionReturn(PETSC_SUCCESS);
94 }
95
sourlf2d(DMDALocalInfo * info,PetscScalar ** in,PetscScalar ** out,void * ptr)96 static PetscErrorCode sourlf2d(DMDALocalInfo *info, PetscScalar **in, PetscScalar **out, void *ptr)
97 {
98 void (*func)(DMDALocalInfo *, PetscScalar *, PetscScalar *, void *, PetscErrorCode *), *ctx;
99 DMSNES sdm;
100
101 PetscFunctionBegin;
102 PetscCall(DMGetDMSNES(info->da, &sdm));
103 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf2d, (PetscFortranCallbackFn **)&func, &ctx));
104 PetscCallFortranVoidFunction((*func)(info, &in[info->gys][info->dof * info->gxs], &out[info->ys][info->dof * info->xs], ctx, &ierr));
105 PetscFunctionReturn(PETSC_SUCCESS);
106 }
107
sourlf3d(DMDALocalInfo * info,PetscScalar *** in,PetscScalar *** out,void * ptr)108 static PetscErrorCode sourlf3d(DMDALocalInfo *info, PetscScalar ***in, PetscScalar ***out, void *ptr)
109 {
110 void (*func)(DMDALocalInfo *, PetscScalar *, PetscScalar *, void *, PetscErrorCode *), *ctx;
111 DMSNES sdm;
112
113 PetscFunctionBegin;
114 PetscCall(DMGetDMSNES(info->da, &sdm));
115 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf3d, (PetscFortranCallbackFn **)&func, &ctx));
116 PetscCallFortranVoidFunction((*func)(info, &in[info->gzs][info->gys][info->dof * info->gxs], &out[info->zs][info->ys][info->dof * info->xs], ctx, &ierr));
117 PetscFunctionReturn(PETSC_SUCCESS);
118 }
119
dmdasnessetfunctionlocal_(DM * da,InsertMode * mode,void (* func)(DMDALocalInfo *,void *,void *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)120 PETSC_EXTERN void dmdasnessetfunctionlocal_(DM *da, InsertMode *mode, void (*func)(DMDALocalInfo *, void *, void *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr)
121 {
122 DMSNES sdm;
123 PetscInt dim;
124
125 *ierr = DMGetDMSNESWrite(*da, &sdm);
126 if (*ierr) return;
127 *ierr = DMDAGetInfo(*da, &dim, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL);
128 if (*ierr) return;
129 if (dim == 2) {
130 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lf2d, (PetscFortranCallbackFn *)func, ctx);
131 if (*ierr) return;
132 *ierr = DMDASNESSetFunctionLocal(*da, *mode, (PetscErrorCode (*)(DMDALocalInfo *, void *, void *, void *))sourlf2d, NULL);
133 } else if (dim == 3) {
134 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lf3d, (PetscFortranCallbackFn *)func, ctx);
135 if (*ierr) return;
136 *ierr = DMDASNESSetFunctionLocal(*da, *mode, (PetscErrorCode (*)(DMDALocalInfo *, void *, void *, void *))sourlf3d, NULL);
137 } else if (dim == 1) {
138 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lf1d, (PetscFortranCallbackFn *)func, ctx);
139 if (*ierr) return;
140 *ierr = DMDASNESSetFunctionLocal(*da, *mode, (PetscErrorCode (*)(DMDALocalInfo *, void *, void *, void *))sourlf1d, NULL);
141 } else *ierr = PETSC_ERR_ARG_OUTOFRANGE;
142 }
143