15
$\begingroup$

Dear Mathematica users,

I would like to numerically solve a, as the title says, Poisson equation with pure Neumann boundary conditions

$-\nabla^2(\psi)=f$
$\nabla(\psi)\cdot \text{n}=g$

Is it possible?

For an example I will use the demo from FEniCS project.

$f=10\text{Exp}(-((x - 0.5)^2 + (y - 0.5)^2)/0.02)$
$g=-\text{Sin}(5x)$

In Mathematica

f = 10*Exp[-(Power[x - 0.5, 2] + Power[y - 0.5, 2])/0.02]
g = -Sin[5*x];
Needs["NDSolve`FEM`"]
bmesh = ToBoundaryMesh["Coordinates" -> {{0., 0.}, {1, 0.}, {1, 1}, {0., 1}, {0.5, 0.5}},"BoundaryElements" -> {LineElement[{{1, 2}, {2, 3}, {3, 4}, {4,1}}]}];
mesh = ToElementMesh[bmesh, "MaxCellMeasure" -> 0.001];

m[x_, y_] = 
 NDSolveValue[{-Laplacian[u[x, y], {x, y}] == f + NeumannValue[g, True]
(*,DirichletCondition[u[x,y]==0, x==0.5&&y==0.5]*)}, u, {x, y} \[Element] mesh][x, y]

ddfdx[x_, y_] := Evaluate[Derivative[1, 0][m][x, y]];
ddfdy[x_, y_] := Evaluate[Derivative[0, 1][m][x, y]];
Show[ContourPlot[m[x, y], {x, y} \[Element] mesh, PlotLegends -> Automatic, Contours -> 50], VectorPlot[{ddfdx[x, y], ddfdy[x, y]}, {x, y} \[Element] mesh, 
  VectorColorFunction -> Hue, VectorScale -> {Small, 0.6, None}]]

Trying to solve this in Mathematica gives a clear and understandable error

NDSolveValue::femibcnd: No DirichletCondition or Robin-type NeumannValue was specified; the result may be off by a constant value.

However, the result is not so clear and understandable.

enter image description here

The answer one would like to get should look something like the following image enter image description here

I tried equation elimination from this post, i.e. using

DirichletCondition[u[x, y] == 0, x == 0.5 && y == 0.5]

to get the result. Now it looks almost decent if one doesn't care about the sink which appears (and wrong gradient). Sadly I do care as I'm interested in the gradient of $\psi$ so such an approach leads me nowhere.

enter image description here

enter image description here

So then the question - is it possible to numerically solve Poisson equation with pure Neumann boundary conditions with Mathematica? Can anyone suggest some steps how to do this?

To add, sadly I am not a mathematician so I lack the ability to implement some routine on my own. Maybe something can be done using the weak formulation as in the example, but before trying to implement (would it actually be possible?) that I would like to learn if there is another way.

$\endgroup$

5 Answers 5

17
+100
$\begingroup$

That's a typical problem; it is caused by the matrix of the discretized system having a one-dimensional kernel (and cokernel). One can stabilize the system by adding a row and a column that represent a homogeneous mean-value constraint. I don't know whether NDSolve can do that (user21 will be able to tell us), but one can do that with low-level FEM-programming:

Needs["NDSolve`FEM`"]
bmesh = ToBoundaryMesh[
   "Coordinates" -> {{0., 0.}, {1, 0.}, {1, 1}, {0., 1}, {0.5, 0.5}}, 
   "BoundaryElements" -> {LineElement[{{1, 2}, {2, 3}, {3, 4}, {4, 1}}]}];
mesh = ToElementMesh[bmesh, "MaxCellMeasure" -> 0.001];

vd = NDSolve`VariableData[{"DependentVariables", "Space"} -> {{u}, {x, y}}];
sd = NDSolve`SolutionData[{"Space"} -> {mesh}];
cdata = InitializePDECoefficients[vd, sd, 
   "DiffusionCoefficients" -> {{-IdentityMatrix[2]}}, 
   "MassCoefficients" -> {{1}}, 
   "LoadCoefficients" -> {{f}}
   ];
bcdata = InitializeBoundaryConditions[vd, sd, {{NeumannValue[g, True]}}];
mdata = InitializePDEMethodData[vd, sd];

(*Discretization*)
dpde = DiscretizePDE[cdata, mdata, sd];
dbc = DiscretizeBoundaryConditions[bcdata, mdata, sd];
{load, stiffness, damping, mass} = dpde["All"];
mass0 = mass;
DeployBoundaryConditions[{load, stiffness}, dbc];

enter image description here

Here the warning message is created. We ignore it because we augment the stiffness matrix in the following way:

a = SparseArray[{Total[mass0]}];
L = ArrayFlatten[{{stiffness, Transpose[a]}, {a, 0.}}];
b = Flatten[Join[load, {0.}]];
v = LinearSolve[L, b, Method -> "Pardiso"][[1 ;; Length[mass]]];

Now we can plot the solution:

solfun = ElementMeshInterpolation[{mesh}, v];
DensityPlot[solfun[x, y], {x, y} ∈ mesh, 
 ColorFunction -> "SunsetColors"]

enter image description here

I leave the cosmetics to you. Beware that the derivatives of these finite-element solutions are guaranteed to be close to the actual solution only in the $L^2$-norm. So it may happen that the gradient vector field looks much rougher than you would expect.

$\endgroup$
14
  • $\begingroup$ @user21 You know probably of a better solution for this... $\endgroup$ Feb 13, 2019 at 17:08
  • $\begingroup$ Thank you for this really insightful answer! A lot to learn about the Finite Element Programming to understand everything here though. Interesting! Still curious and eager to learn something from @user21.. $\endgroup$ Feb 18, 2019 at 10:32
  • $\begingroup$ You're welcome! Have also a look at the extensive tutorial on FEM written by user21. $\endgroup$ Feb 18, 2019 at 10:33
  • $\begingroup$ @Mefistofelis, I only saw this now; for some reason I did not get a @ notification. I'll try to have a look at this in the next few days if still needed. $\endgroup$
    – user21
    Feb 18, 2019 at 14:01
  • $\begingroup$ @user21 Thank you. =D $\endgroup$ Feb 20, 2019 at 15:44
14
$\begingroup$

We can use the method of the false transient:

f = 10*Exp[-(Power[x - 0.5, 2] + Power[y - 0.5, 2])/0.02];
g = -Sin[5*x];
Needs["NDSolve`FEM`"]
bmesh = ToBoundaryMesh[
   "Coordinates" -> {{0., 0.}, {1, 0.}, {1, 1}, {0., 1}, {0.5, 0.5}}, 
   "BoundaryElements" -> {LineElement[{{1, 2}, {2, 3}, {3, 4}, {4, 
        1}}]}];
mesh = ToElementMesh[bmesh, "MaxCellMeasure" -> 0.001];
t0 = 300; dif = 1000;
m = NDSolveValue[{dif*D[u[t, x, y], t] - f - 
     Laplacian[u[t, x, y], {x, y}] == NeumannValue[g, True], 
   u[0, x, y] == 0}, u, {t, 0, t0}, {x, y} \[Element] mesh]

Visualisation

{Show[ContourPlot[m[t0, x, y], {x, y} \[Element] mesh, 


 PlotLegends -> Automatic, Contours -> 50, 
   ColorFunction -> "BlueGreenYellow"], 
  VectorPlot[
   Evaluate[Grad[m[t, x, y], {x, y}] /. t -> t0], {x, y} \[Element] 
    mesh, VectorColorFunction -> Hue, 
   VectorScale -> {Small, 0.6, None}]], 
 DensityPlot[m[t0, x, y], {x, y} \[Element] mesh, 
  PlotLegends -> Automatic, ColorFunction -> "SunsetColors"]}

Figure 1

$\endgroup$
5
  • $\begingroup$ I think your source has the wrong sign. $\endgroup$
    – ConvexHull
    Jul 27 at 10:09
  • $\begingroup$ Wrong sign compare to what? $\endgroup$ Jul 27 at 11:16
  • 1
    $\begingroup$ Compared to the other solutions presented here. I recover your solution if the sign of f is changed. To be honest, the derivative in normal direction is also not uniquely defined in this Fenics example. How is the orientation of the normal vector defined? Always pointing outward? $\endgroup$
    – ConvexHull
    Jul 27 at 11:48
  • $\begingroup$ You are right, thank you very much, post been corrected with a new picture. $\endgroup$ Jul 27 at 12:02
  • $\begingroup$ Your welcome! ;) $\endgroup$
    – ConvexHull
    Jul 27 at 12:03
12
$\begingroup$

I have an approach that is similar to Henrik's but is a bit more streamlined and possibly more efficient.

Let's start with some definitions and the mesh:

f = 10*Exp[-(Power[x - 0.5, 2] + Power[y - 0.5, 2])/0.02];
g = -Sin[5*x];

Needs["NDSolve`FEM`"]
mesh = ToElementMesh[Rectangle[]];

Then there is a utility function that is not documented that we can use here. It's purpose to the take a PDE, BCs, ics and a region and generate the discretized versions from them. I'll use the same names, then it should be clear what the function does.

{dpde, dbc, vd, sd, mdata} = 
  ProcessPDEEquations[{-Laplacian[u[x, y], {x, y}]
     == f + NeumannValue[g, True]}, u, {x, y} \[Element] mesh];
{load, stiffness, damping, mass} = dpde["All"];
DeployBoundaryConditions[{load, stiffness}, dbc];

This generates the same data as in Henrik's post. Now, we write a helper function that implements the integral constraint. We need, loosely speaking, the contribution of each node to the total area of the region. Now, there is the mesh["MeshElementMeasure"] which gives the area contribution of each element. What we are looking for is the 'area' contribution 'surrounding' each mesh node, figuratively speaking. Henrik extracted that information from the mass matrix. I used the load vector. That should be a bit more efficient and needs less data massaging. But it the same principal. To get those values we use the discretization mechanism we already have. We set the load coefficient to 1. If you were to sum some over the discretized load vector, you'd get the area of the region. The constraint matrix contains the value we like this integral to be, 0 in this case. Then I fill in the data structure that DeployBoundaryCondition needs.

FEMIntegralConstraint[value_, methodData_, vd_, sd_] := Module[
  {prec, dof, loadContribution, stiffnessContribution, initCoeffs, 
   constraintMatrix, constraintRows, constraintValueMatrix},      

  prec = methodData["Precision"];
  dof = methodData["DegreesOfFreedom"];

  (* no values are added to the load vector and stiffness matrix *)
  loadContribution = SparseArray[{}, {dof, 1}, N[0, prec]];
  stiffnessContribution = SparseArray[{}, {dof, dof}, N[0, prec]];

  (* init the load coefficient to 1 *)
  initCoeffs = InitializePDECoefficients[vd, sd, "LoadCoefficients" -> {{1}}];

  (* values inserted into the stiffness matrix overwriting what there was *)
  constraintMatrix = Transpose[
    DiscretizePDE[initCoeffs, methodData, sd]["LoadVector"]];

  constraintRows = {1};
  (* values inseted into the load vector, overwriting what there was *)
    constraintValueMatrix = SparseArray[{{N[value, prec]}}];

  DiscretizedBoundaryConditionData[{loadContribution, 
    stiffnessContribution, constraintMatrix, constraintRows, 
    constraintValueMatrix,
    (* DOF, hanging nodes DOF, 
    lagrangian multipliers DOF *)
    {dof, 0, Length[constraintRows]}},
   (* scale factor value *)
   1]
  ]

With this in place we can now construct the integral constraint and deploy those. "Append" means those constraints are appended to the system matrices (as Lagrange multipliers)

dbc = FEMIntegralConstraint[0, mdata, vd, sd]
DeployBoundaryConditions[{load, stiffness}, dbc, 
 "ConstraintMethod" -> "Append" ]

The rest is the same:

v = LinearSolve[stiffness, load];
solfun3 = 
  ElementMeshInterpolation[{mesh}, Take[v, mdata["DegreesOfFreedom"]]];

We can check that the constraint worked:

NIntegrate[solfun3[x, y], {x, y} \[Element] mesh]
1.1645204900769326`*^-7

Which is quite acceptable, I think. Also there is no difference to the result Henrik provided.

Show[ContourPlot[solfun3[x, y], {x, y} \[Element] mesh, 
  PlotLegends -> Automatic, Contours -> 50, 
  ColorFunction -> "BlueGreenYellow"], 
 VectorPlot[
  Evaluate[Grad[solfun3[x, y], {x, y}]], {x, y} \[Element] mesh, 
  VectorColorFunction -> Hue, VectorScale -> {Small, 0.6, None}]]

enter image description here

One thing is that the result on your linked page seems to have a bit higher a max value, but I may be wrong. If you have it installed, I'd check the values.

Update:

For version 10 you may be lucky and can use this as a replacement for ProcessPDEEquations. If the vd does not work you could try to get it from the methodData["VariableData"] in stead.

PDEtoMatrix[{pde_, \[CapitalGamma]___}, u_, r__] := 
 Module[{ndstate, feData, sd, vd, bcData, methodData, pdeData},
  {ndstate} =
   NDSolve`ProcessEquations[Flatten[{pde, \[CapitalGamma]}], u, 
    Sequence @@ {r}];
  sd = ndstate["SolutionData"][[1]]; vd = ndstate["VariableData"];
  feData = ndstate["FiniteElementData"];
  pdeData = feData["PDECoefficientData"];
  bcData = feData["BoundaryConditionData"];
  methodData = feData["FEMMethodData"];
  {DiscretizePDE[pdeData, methodData, sd], 
   DiscretizeBoundaryConditions[bcData, methodData, sd], vd, sd, 
   methodData}
  ]

An explanation for PDEtoMatrix can be found in the talk here.

$\endgroup$
4
  • $\begingroup$ By any chance something of this might not work in Mathematica 10 (or 10.2, suppose I had to mention this at start, my apologies!)? Direct usage of your code is not possible, e.g. first list equality is not the same length. $\endgroup$ Feb 19, 2019 at 18:18
  • $\begingroup$ @Mefistofelis, I no longer have a version 10 installed. Does Henrik's version work for you? $\endgroup$
    – user21
    Feb 20, 2019 at 5:46
  • $\begingroup$ Correct. As you used the same names as Henrik (and thank you for that!), it is clear that the 'utility function' ProcessPDEEquations doesn't work for older versions, i.e. nothing is returned. However, I suppose, one can combine both answers, taking your part from the implementation of the integral constraint and using Henriks way of doing discretization. And then your way works perfectly! Thank you! $\endgroup$ Feb 20, 2019 at 14:11
  • $\begingroup$ @Mefistofelis, yes, this should indeed work. Or, alternatively you could roll your own function ProcessPDEEquations or call is something else, see update. $\endgroup$
    – user21
    Feb 20, 2019 at 14:35
8
$\begingroup$

I'd like to add a finite difference method (FDM) based solution. I'll use pdetoae for the generation of difference equations.

f = 10 Exp[-(Power[x - 0.5, 2] + Power[y - 0.5, 2])/0.02];
g = -Sin[5 x];

With[{u = u[x, y]},
  eq = -Laplacian[u, {x, y}] == f;
  bc = {Table[D[u, var] == g /. var -> 1, {var, {x, y}}],
        Table[D[u, var] == - g /. var -> 0, {var, {x, y}}]}
  ];
points = 25; domain = {0, 1};
grid = Array[# &, points, domain];
difforder = 2;
ptoafunc = pdetoae[u[x, y], {grid, grid}, difforder];
(* Definition of pdetoae isn't included in this post,
   please find it in the link above. *)
ae = ptoafunc@eq;
aebc = ptoafunc@bc;
var = Outer[u, grid, grid, 1];
constbc = u[0, 0] == 0;

At this point we have points × points + points × 4 + 1 equations at hand, but only points × points unknown variables therein, so the equation system is over-determined. Usually the solution is to remove some of the equations from the system as I've done many times before, but this method doesn't work well in this case:

del = #[[2 ;; -2]] &;
{b, mat} = CoefficientArrays[{del /@ del@ae, 
      Delete[MapAt[del, aebc, {1, All}], {2, 2, 1}], constbc} // Flatten, 
    var // Flatten]; // AbsoluteTiming

sollst = LinearSolve[N@mat, -b]; // AbsoluteTiming

LinearSolve::nosol

To be honest, I'm not sure why this happens, but anyway, I've found a workaround. We just need to turn to LeastSquares:

{b, mat} = CoefficientArrays[{ae, aebc, constbc} // Flatten, 
    var // Flatten]; // AbsoluteTiming

sollst = LeastSquares[N@mat, -b]; // AbsoluteTiming    
solmat = Partition[sollst, points, points];
solfunc = ListInterpolation[solmat, {grid, grid}];

Show[ContourPlot[solfunc[x, y], {x, ##}, {y, ##}, PlotLegends -> Automatic, 
    Contours -> 50, ColorFunction -> "AvocadoColors"], 
   VectorPlot[Evaluate[Grad[solfunc[x, y], {x, y}]], {x, ##}, {y, ##}, 
    VectorColorFunction -> "TemperatureMap"]] & @@ domain

Mathematica graphics

$\endgroup$
6
  • $\begingroup$ Hi. Looking at your legend it seems the range is from 0 to 1.0 - can you check what the Integral over you solution is? Should be zero I think. $\endgroup$
    – user21
    Feb 20, 2019 at 6:23
  • $\begingroup$ @user21 For points = 50 it's about 0.495172, but I think it's reasonable, because I'm not using constant integral as the constraint here, mine is constbc = u[0, 0] == 0;. $\endgroup$
    – xzczd
    Feb 20, 2019 at 6:28
  • $\begingroup$ I see; However, u[0,0]==0 is a Dirichlet condition or am I missing something? $\endgroup$
    – user21
    Feb 20, 2019 at 6:53
  • 1
    $\begingroup$ Yes, I think that is correct. I am not sure why the LinearSolve fails. To get to the integral you could use an iterative process to adjust the Dirichlet bc in such a way that the integral becomes 0. $\endgroup$
    – user21
    Feb 20, 2019 at 7:05
  • 3
    $\begingroup$ One could also simply subtract the solution's average from the solution... $\endgroup$ Feb 20, 2019 at 16:28
0
$\begingroup$

Although the question is already a little older, I want to share an answer with two solution strategies using a Discontinuous Galerkin method (LDG):

  1. Modifying the equation

$$-\Delta u = f,$$ $$\text{...}$$ $$-\Delta u + \varepsilon u = f,$$

for some small $\varepsilon>0$, which can be interpreted as a regularization (e.g. Tikhonov). This corresponds roughly to adding $\varepsilon$ to the diagonal of your system matrix (Jitter).

  1. Imposing an additional constraint

$$\int_\Omega u \,\mathrm{d}x=0,$$

using Lagrange multiplier. Then your system would be $$\begin{bmatrix} A & 1 \\ 1^T & 0 \end{bmatrix} \begin{bmatrix} u \\ \lambda \end{bmatrix} = \begin{bmatrix} f \\ 0 \end{bmatrix}.$$

See also: Stack Computational Science

Results

  • Mesh with 4x4 elements
  • Polynomial degree of 6
  • $\epsilon = 1\times 10^{-6}$

First method

enter image description here

Second method

enter image description here

$\endgroup$
7
  • 2
    $\begingroup$ Welcome. Would be nice if you could add the code for 1. 2 is essentially the answer Henrik has given, not? $\endgroup$
    – user21
    Aug 5 at 1:10
  • $\begingroup$ @user21 My contribution focuses more on numerical and mathematical part. It's not directly done in Mathematica. So unfortunately the answer is no.The second method is more or less good described by Henrik. $\endgroup$
    – ConvexHull
    Aug 5 at 11:08
  • $\begingroup$ You understand that the point of this site is to share Mathematica code. If OP wanted a numerical or mathematica description he/she would have asked elsewhere. $\endgroup$
    – user21
    Aug 5 at 15:06
  • $\begingroup$ To put in other words: showing plots created in something else then Mathematica is not useful on this site because none can replicate that. You could use the online version of the Wolfram language and share your code. $\endgroup$
    – user21
    Aug 5 at 15:13
  • $\begingroup$ Can you elaborate how you version is different from Henriks'? How is it advantageous? $\endgroup$
    – user21
    Aug 5 at 15:15

Not the answer you're looking for? Browse other questions tagged or ask your own question.