10
$\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$
11
+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$
  • $\begingroup$ @user21 You know probably of a better solution for this... $\endgroup$ – Henrik Schumacher Feb 13 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$ – Mefistofelis Feb 18 at 10:32
  • $\begingroup$ You're welcome! Have also a look at the extensive tutorial on FEM written by user21. $\endgroup$ – Henrik Schumacher Feb 18 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 at 14:01
  • $\begingroup$ @user21 Thank you. =D $\endgroup$ – Henrik Schumacher Feb 20 at 15:44
9
$\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]


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}]]

fig1

$\endgroup$
8
$\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$
  • $\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$ – Mefistofelis Feb 19 at 18:18
  • $\begingroup$ @Mefistofelis, I no longer have a version 10 installed. Does Henrik's version work for you? $\endgroup$ – user21 Feb 20 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$ – Mefistofelis Feb 20 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 at 14:35
5
$\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$
  • $\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 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 at 6:28
  • $\begingroup$ I see; However, u[0,0]==0 is a Dirichlet condition or am I missing something? $\endgroup$ – user21 Feb 20 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 at 7:05
  • 2
    $\begingroup$ One could also simply subtract the solution's average from the solution... $\endgroup$ – Henrik Schumacher Feb 20 at 16:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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