1 #include <petsc-private/fortranimpl.h> 2 #include <petsc-private/daimpl.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 EXTERN_C_BEGIN 22 /************************************************/ 23 static PetscErrorCode sourlj1d(DMDALocalInfo *info,PetscScalar *in,Mat A,Mat m,MatStructure *str,void *ptr) 24 { 25 PetscErrorCode ierr; 26 void (PETSC_STDCALL *func)(DMDALocalInfo*,PetscScalar*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*),*ctx; 27 DMSNES sdm; 28 29 PetscFunctionBegin; 30 ierr = DMGetDMSNES(info->da,&sdm);CHKERRQ(ierr); 31 ierr = PetscObjectGetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,_cb.lj1d,(PetscVoidFunction*)&func,&ctx);CHKERRQ(ierr); 32 (*func)(info,&in[info->dof*info->gxs],&A,&m,str,ctx,&ierr);CHKERRQ(ierr); 33 PetscFunctionReturn(0); 34 } 35 36 static PetscErrorCode sourlj2d(DMDALocalInfo *info,PetscScalar **in,Mat A,Mat m,MatStructure *str,void *ptr) 37 { 38 PetscErrorCode ierr; 39 void (PETSC_STDCALL *func)(DMDALocalInfo*,PetscScalar*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*),*ctx; 40 DMSNES sdm; 41 42 PetscFunctionBegin; 43 ierr = DMGetDMSNES(info->da,&sdm);CHKERRQ(ierr); 44 ierr = PetscObjectGetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,_cb.lj2d,(PetscVoidFunction*)&func,&ctx);CHKERRQ(ierr); 45 (*func)(info,&in[info->gys][info->dof*info->gxs],&A,&m,str,ctx,&ierr);CHKERRQ(ierr); 46 PetscFunctionReturn(0); 47 } 48 49 static PetscErrorCode sourlj3d(DMDALocalInfo *info,PetscScalar ***in,Mat A,Mat m,MatStructure *str,void *ptr) 50 { 51 PetscErrorCode ierr; 52 void (PETSC_STDCALL *func)(DMDALocalInfo*,PetscScalar*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*),*ctx; 53 DMSNES sdm; 54 55 PetscFunctionBegin; 56 ierr = DMGetDMSNES(info->da,&sdm);CHKERRQ(ierr); 57 ierr = PetscObjectGetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,_cb.lj2d,(PetscVoidFunction*)&func,&ctx);CHKERRQ(ierr); 58 (*func)(info,&in[info->gzs][info->gys][info->dof*info->gxs],&A,&m,str,ctx,&ierr);CHKERRQ(ierr); 59 PetscFunctionReturn(0); 60 } 61 62 void PETSC_STDCALL dmdasnessetjacobianlocal_(DM *da,void (PETSC_STDCALL *jac)(DMDALocalInfo*,void*,void*,void*,void*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 63 { 64 DMSNES sdm; 65 PetscInt dim; 66 67 *ierr = DMGetDMSNESWrite(*da,&sdm); if (*ierr) return; 68 *ierr = DMDAGetInfo(*da,&dim,0,0,0,0,0,0,0,0,0,0,0,0); if (*ierr) return; 69 if (dim == 2) { 70 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.lj2d,(PetscVoidFunction)jac,ctx); if (*ierr) return; 71 *ierr = DMDASNESSetJacobianLocal(*da,(PetscErrorCode (*)(DMDALocalInfo*,void*,Mat,Mat,MatStructure*,void*))sourlj2d,PETSC_NULL); 72 } else if (dim == 3) { 73 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.lj3d,(PetscVoidFunction)jac,ctx); if (*ierr) return; 74 *ierr = DMDASNESSetJacobianLocal(*da,(PetscErrorCode (*)(DMDALocalInfo*,void*,Mat,Mat,MatStructure*,void*))sourlj3d,PETSC_NULL); 75 } else if (dim == 1) { 76 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.lj1d,(PetscVoidFunction)jac,ctx); if (*ierr) return; 77 *ierr = DMDASNESSetJacobianLocal(*da,(PetscErrorCode (*)(DMDALocalInfo*,void*,Mat,Mat,MatStructure*,void*))sourlj1d,PETSC_NULL); 78 } else *ierr = 1; 79 } 80 81 /************************************************/ 82 83 static PetscErrorCode sourlf1d(DMDALocalInfo *info,PetscScalar *in,PetscScalar *out,void *ptr) 84 { 85 PetscErrorCode ierr; 86 void (PETSC_STDCALL *func)(DMDALocalInfo*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),*ctx; 87 DMSNES sdm; 88 89 PetscFunctionBegin; 90 ierr = DMGetDMSNES(info->da,&sdm);CHKERRQ(ierr); 91 ierr = PetscObjectGetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,_cb.lf1d,(PetscVoidFunction*)&func,&ctx);CHKERRQ(ierr); 92 (*func)(info,&in[info->dof*info->gxs],&out[info->dof*info->xs],ctx,&ierr);CHKERRQ(ierr); 93 PetscFunctionReturn(0); 94 } 95 96 static PetscErrorCode sourlf2d(DMDALocalInfo *info,PetscScalar **in,PetscScalar **out,void *ptr) 97 { 98 PetscErrorCode ierr; 99 void (PETSC_STDCALL *func)(DMDALocalInfo*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),*ctx; 100 DMSNES sdm; 101 102 PetscFunctionBegin; 103 ierr = DMGetDMSNES(info->da,&sdm);CHKERRQ(ierr); 104 ierr = PetscObjectGetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,_cb.lf2d,(PetscVoidFunction*)&func,&ctx);CHKERRQ(ierr); 105 (*func)(info,&in[info->gys][info->dof*info->gxs],&out[info->ys][info->dof*info->xs],ctx,&ierr);CHKERRQ(ierr); 106 PetscFunctionReturn(0); 107 } 108 109 static PetscErrorCode sourlf3d(DMDALocalInfo *info,PetscScalar ***in,PetscScalar ***out,void *ptr) 110 { 111 PetscErrorCode ierr; 112 void (PETSC_STDCALL *func)(DMDALocalInfo*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),*ctx; 113 DMSNES sdm; 114 115 PetscFunctionBegin; 116 ierr = DMGetDMSNES(info->da,&sdm);CHKERRQ(ierr); 117 ierr = PetscObjectGetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,_cb.lf3d,(PetscVoidFunction*)&func,&ctx);CHKERRQ(ierr); 118 (*func)(info,&in[info->gzs][info->gys][info->dof*info->gxs],&out[info->zs][info->ys][info->dof*info->xs],ctx,&ierr);CHKERRQ(ierr); 119 PetscFunctionReturn(0); 120 } 121 122 void PETSC_STDCALL dmdasnessetfunctionlocal_(DM *da,InsertMode *mode,void (PETSC_STDCALL *func)(DMDALocalInfo*,void*,void*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 123 { 124 DMSNES sdm; 125 PetscInt dim; 126 127 *ierr = DMGetDMSNESWrite(*da,&sdm); if (*ierr) return; 128 *ierr = DMDAGetInfo(*da,&dim,0,0,0,0,0,0,0,0,0,0,0,0); if (*ierr) return; 129 if (dim == 2) { 130 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.lf2d,(PetscVoidFunction)func,ctx); if (*ierr) return; 131 *ierr = DMDASNESSetFunctionLocal(*da,*mode,(PetscErrorCode (*)(DMDALocalInfo*,void*,void*,void*))sourlf2d,PETSC_NULL); 132 } else if (dim == 3) { 133 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.lf3d,(PetscVoidFunction)func,ctx); if (*ierr) return; 134 *ierr = DMDASNESSetFunctionLocal(*da,*mode,(PetscErrorCode (*)(DMDALocalInfo*,void*,void*,void*))sourlf3d,PETSC_NULL); 135 } else if (dim == 1) { 136 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm,PETSC_FORTRAN_CALLBACK_SUBTYPE,&_cb.lf1d,(PetscVoidFunction)func,ctx); if (*ierr) return; 137 *ierr = DMDASNESSetFunctionLocal(*da,*mode,(PetscErrorCode (*)(DMDALocalInfo*,void*,void*,void*))sourlf1d,PETSC_NULL); 138 } else *ierr = 1; 139 } 140 141 EXTERN_C_END 142