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