Actual source code: zdmdasnesf.c

      1: #include <petsc/private/fortranimpl.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

     12: static struct {
     13:   PetscFortranCallbackId lf1d;
     14:   PetscFortranCallbackId lf2d;
     15:   PetscFortranCallbackId lf3d;
     16:   PetscFortranCallbackId lj1d;
     17:   PetscFortranCallbackId lj2d;
     18:   PetscFortranCallbackId lj3d;
     19: } _cb;

     21: /************************************************/
     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;

     27:   PetscFunctionBegin;
     28:   PetscCall(DMGetDMSNES(info->da, &sdm));
     29:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj1d, (PetscVoidFn **)&func, &ctx));
     30:   PetscCallFortranVoidFunction((*func)(info, &in[info->dof * info->gxs], &A, &m, ctx, &ierr));
     31:   PetscFunctionReturn(PETSC_SUCCESS);
     32: }

     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;

     39:   PetscFunctionBegin;
     40:   PetscCall(DMGetDMSNES(info->da, &sdm));
     41:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj2d, (PetscVoidFn **)&func, &ctx));
     42:   PetscCallFortranVoidFunction((*func)(info, &in[info->gys][info->dof * info->gxs], &A, &m, ctx, &ierr));
     43:   PetscFunctionReturn(PETSC_SUCCESS);
     44: }

     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;

     51:   PetscFunctionBegin;
     52:   PetscCall(DMGetDMSNES(info->da, &sdm));
     53:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj2d, (PetscVoidFn **)&func, &ctx));
     54:   PetscCallFortranVoidFunction((*func)(info, &in[info->gzs][info->gys][info->dof * info->gxs], &A, &m, ctx, &ierr));
     55:   PetscFunctionReturn(PETSC_SUCCESS);
     56: }

     58: PETSC_EXTERN void dmdasnessetjacobianlocal_(DM *da, void (*jac)(DMDALocalInfo *, void *, void *, void *, void *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
     59: {
     60:   DMSNES   sdm;
     61:   PetscInt dim;

     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, (PetscVoidFn *)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, (PetscVoidFn *)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, (PetscVoidFn *)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: }

     82: /************************************************/

     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;

     89:   PetscFunctionBegin;
     90:   PetscCall(DMGetDMSNES(info->da, &sdm));
     91:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf1d, (PetscVoidFn **)&func, &ctx));
     92:   PetscCallFortranVoidFunction((*func)(info, &in[info->dof * info->gxs], &out[info->dof * info->xs], ctx, &ierr));
     93:   PetscFunctionReturn(PETSC_SUCCESS);
     94: }

     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;

    101:   PetscFunctionBegin;
    102:   PetscCall(DMGetDMSNES(info->da, &sdm));
    103:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf2d, (PetscVoidFn **)&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: }

    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;

    113:   PetscFunctionBegin;
    114:   PetscCall(DMGetDMSNES(info->da, &sdm));
    115:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf3d, (PetscVoidFn **)&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: }

    120: PETSC_EXTERN void dmdasnessetfunctionlocal_(DM *da, InsertMode *mode, void (*func)(DMDALocalInfo *, void *, void *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    121: {
    122:   DMSNES   sdm;
    123:   PetscInt dim;

    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, (PetscVoidFn *)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, (PetscVoidFn *)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, (PetscVoidFn *)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: }