Finite difference method not converging to correct steady state or conserving area?

Question

I am working with the following PDE, which is an advection-diffusion type equation. It describes the movement of a fluid-fluid interface inside an annulus of inner radius $R_1$ and outer $R_2$ under the action of gravity, where one fluid is denser than another. I am trying to solve it via a finite-difference scheme. I am working in polar coordinates.

$h_t + \left[(h-R_1)^2(h-R_2)^2(h_\theta \sin \theta +h\cos \theta)\right]_\theta = 0$

The physical steady state for this system is a flat interface (dense fluid runs downhill until it all collects in the bottom of the annulus with light fluid above). We can check if the physical intuition of flat interface final state truly is a steady state solution ($h_t = 0$) of our PDE.

Indeed, if we ignore trivial steady states of $h = R_1$ and $h = R_2$ which correspond to the interface being on an annulus boundary (ie. annulus entirely filled with only one fluid) then, $h_t = 0$ when $(h_\theta \sin \theta +h\cos \theta) = const$. Solving this (WLOG $const$ = 0) leads us to $h = C\csc\theta$, which indeed corresponds to flat $y = C$ solutions.

Additionally clearly the PDE also conserves area, as it can be written in flux conservative form.

So now I attempt to solve this PDE with an initial interface position, and march time forward until the interface relaxes to the physical steady state solution.

Let us set $R_1 = 1, R_2 = 2$.

My finite difference code is as follows:

n = 201; 
ds = 1./n;
ClearAll[dh, t];
dh[h_List] := 
  With[{s = Array[# &, n, {-5/6 π, -π/6}], 
    d1 = ListCorrelate[{-0.5, 0, 0.5}/ds, #] &, 
    d2 = ListCorrelate[{1, -2, 1}/ds^2, #] &}, 

(* Setting up the grid, derivatives etc. *)

(-2 + h) (-1 + h) (-4 Cos[s] d1[#1] - 6 (-2 + h) h Cos[s] d1[#1] + (6 d1[#1]^2 - 2 d2[#1] + h (2 + h^2 - 4 d1[#1]^2 + 3 d2[#1] - h (3 + d2[#1]))) Sin[s]) &@Join[{2}, h, {2}]];

The PDE, with Dirichlet conditions added to the end points, such that the interface stays on the outer boundary.

h0 = Flatten@Join[ConstantArray[1.999, 51], ConstantArray[1.001, 100], ConstantArray[1.999, 50]];

Initial condition

sol = NDSolve[{h'[t] == dh[h[t]], h[0] == h0}, h, {t, 0, 5}][[1, 1, 2]];

We can now visualise the solution

Needs@"DifferentialEquations`InterpolatingFunctionAnatomy`";
valh = InterpolatingFunctionValuesOnGrid@sol;
ti = Flatten@InterpolatingFunctionGrid@sol;
s = Array[# &, n, {-5/6 π, -π/6}];
h = ListInterpolation[valh, {ti, s}]

To aid with visualisation. I will plot the line at which the steady state should lie, which can be calculated from simple geometry.

ListAnimate@Table[Show[PolarPlot[Evaluate[h[ti, θ]], {θ, -5/6 π, -π/6}, PlotRange -> {{-2, 2}, {-2, 2}}, ImageSize -> Large, PlotStyle -> Black], 
RegionPlot[1 <= x^2 + y^2 <= 4, {x, -2, 2}, {y, -2, 2},PlotStyle -> Opacity[0.1], AspectRatio -> 1], 
PolarPlot[2 Sin[-2.4539664700963293`]/ Sin[θ], {θ,-2.4539664700963293`, -0.6876261834934637`}, PlotStyle -> Red]], {ti, 0, 5, 0.1}]

We can see from looking at snapshots in time, that the current initially does as expected. Slumping and running, but then something strange happens, it "overshoots" the steady state and goes under it. Clearly not conserving volume (area). It then appears to tend to the $h = 2$ steady state.

I am a bit perplexed about why it is doing this? There must be an error with my finite difference scheme?

EDIT - Further Details

If I make the initial condition something a little "nicer", a smooth parabolic shape for example. The system can be solved easily by NDSolve. In this case, the interface tends to the correct (physically intuitive) steady state and conserves area. This suggests to me that there is an error in my FTCS finite difference scheme.

Here is the code:

 pde = D[h[θ, t], t] == -D[(-1 + h[θ, t])^2 (h[θ, t] -2)^2 (Cos[θ] h[θ, t] + Sin[θ] D[h[θ, t], θ]), θ];

sol = NDSolve[{pde, h[-((5 π)/6), t] == 1.999, h[-(π/6), t] ==1.999, h[θ, 0] == 2.3102500000000017` + 0.7133324549378759` θ + 0.22706077254247925` θ^2}, h, {θ, -((5 π)/6), -(π/6)}, {t, 0, 10}, MaxStepSize -> 0.01]

ListAnimate@
 Table[Show[
   PolarPlot[
    Evaluate[
     h[θ, t] /. sol], {θ, -((5 π)/6), -(π/6)}, 
    PlotRange -> {{-2, 2}, {-2, 2}}, ImageSize -> Large, 
    PlotStyle -> Black], 
    PolarPlot[2*Sin[-2.217941839687187`]/Sin[x], {x, -2.217941839687187`, -0.9236508139026061`}, PlotStyle -> Red]
   RegionPlot[1 <= x^2 + y^2 <= 4, {x, -2, 2}, {y, -2, 2}, 
    PlotStyle -> Opacity[0.1], AspectRatio -> 1]], {t, 0, 10, 0.1}]

If I try and use NDSolve with my desired initial condition. I use

int = Interpolation[Transpose@{s,h0}]

however, I get an error about the PDE being stiff. I presume this is because of the large gradients seen at the nose of the current in the first gif.

Answer 1

Introduction

A lack of time to write up an answer ironically provided time to reflect on the problem, and some nagging uncertainties about some issues contributed to the delay.

The slowness of the OP's code can be seen by a simple analysis, which reveals that some expensive calculations are repeated multiple times for each step in the time integration. A more important concern is whether area is conserved by the DE. The OP asserts yes, but I'm thinking not. I wonder which of us is correct. This issue has slowed my response, because I assumed area was conserved, which led to things not making sense. I first thought I could explain the change in area in terms of the finite-difference discretization. It does contribute to it, but not as much as the underlying differential equation. This was confusing to me until I accepted the hypothesis that area is not conserved. Similarly, a difference of opinion about the proper value of the grid spacing ds has made me hesitate some.

Code analysis

The OP's code for dh[] is clearly written and this is plugged into a simple straight-forward NDSolve call, so the whole is not hard to analyze.

Dependence and independence

I have found that I save myself some headaches if variables that depend on one another are constructed in code that reflects the dependency. Let's look at some of the quantities in the code, in particular s and ds.

First, ds and s are intimately linked to each, but their codes are independent. This is a weakness and a potential source for bugs. We should have ds = s[[2]] - s[[1]] (since it is a regular grid). Similarly, h0 depends on n but is not defined in terms of n; indeed, it probably ought to be a function of θ and applied to s.

Control flow

The principal thing to notice is that in dh[], each of d1[#] and d2[#] is repeated several times and each entails a ListCorrelate[] computation to be repeated. This will slow things down unnecessarily. By contrast, @xzczd's fast solution calculates dh[h] just once; even though it is a symbolic computation and somewhat slower than a numerical one, it is not nearly as slow as repeating calculations again and again throughout the steps of the time integration.

Leveraging Mathematica

1. As shown in the tutorial, The Numerical Method of Lines, NDSolve`FiniteDifferenceDerivative[] will compute finite difference derivatives. It is virtually the same as the OP's ListCorrelation[] codes (with the appropriate "DifferenceOrder", with one difference: FiniteDifferenceDerivative[] uses a higher order approximation at the end points of the grid instead of padding (as the OP does with {2.}). The OP's results may be obtained by manually padding in the same way and dropping the first and last results from FiniteDifferenceDerivative[]. For instance, these give the same results as d1 and d2 respectively:

s = Array[# &, n, {-5/6 π, -π/6}];
ds = s[[2]] - s[[1]];  (* == Pi/300 for n = 201 *)
paddedgrid = Join[{First[s] - ds}, s, {Last[s] + ds}];
paddedh0 = Join[{2.}, h0, {2.}];

NDSolve`FiniteDifferenceDerivative[1, paddedgrid,    (* == d1[h0] *)
    "DifferenceOrder" -> 2][paddedh0][[2 ;; -2]]
NDSolve`FiniteDifferenceDerivative[2, paddedgrid,    (* == d2[h0] *)
    "DifferenceOrder" -> 1][paddedh0][[2 ;; -2]]

Note that NDSolve`FiniteDifferenceDerivative does not depend on ds and can be used just in terms of s.

2. A minor point: The following is equivalent to the OP's use of ListCorrelation, padding h with 2. on the left and right:

d1 = ListCorrelate[{-0.5, 0, 0.5}/ds, h, {-2, 2}, 2.]
d2 = ListCorrelate[{1, -2, 1}/ds^2, h, {-2, 2}, 2.]

3. In addition, the OP's use of dh[h[t]], with dh[h_List], means that NDSolve will treat dh[] as a numeric black box, whereas , @xzczd's dh[h] constructs a (large) system of symbolic equations. It seems clear, from the difference in the number of steps shown below, that this affects the integration method used by NDSolve.

Improvement of speed in dh[]

Aside from eliminating the redundant computations outline above, the use of machine numbers, packed arrays, and vectorized operations, as discussed in Performance tuning in Mathematica?, can be used to increase speed. Compile also helps quite a bit. (The code for Compile was constructed from the OP's ode, and I used $ variables to avoid conflicting with other things.) One could do it with the padded grid shown above, which would add a little to the computation time, but I'll do it with the simpler approach.

ClearAll[dh2, s];

n = 201;
s = Developer`ToPackedArray@N@Array[# &, n, {-5/6 π, -π/6}];

dhC = Compile[{{$h, _Real, 1}, {$d1, _Real, 1}, {$d2, _Real, 1},
               {$s, _Real, 1}, {$c, _Real, 1}},
   -2 $d1 (-2 + $h)^2 (-1 + $h) ($c $h + $d1 $s) - 
    2 $d1 (-2 + $h) (-1 + $h)^2 ($c $h + $d1 $s) -
    (-2 + $h)^2 (-1 + $h)^2 (2 $c $d1 + $d2 $s - $h $s)
   ];

With[{ (* compute derivatives and Sin[s], Cos[s] just once *)
   d1FN = NDSolve`FiniteDifferenceDerivative[1, s, "DifferenceOrder" -> 2],
   d2FN = NDSolve`FiniteDifferenceDerivative[2, s, "DifferenceOrder" -> 1],
   sin = Sin[s],
   cos = Cos[s]},
 dh2[h_List] := With[{d1 = d1FN@h, d2 = d2FN@h},
   dhC[h, d1, d2, sin, cos]]
 ];

Performance comparison

I wanted to compare evaluations of the right-hand side of the ODE, steps, and time. I added an option EvaluationMonitor :> ++evals to the NDSolve code for each case. I timed the solutions with code like the following one for my case:

{sol2} = h /. NDSolve[{h'[t] == dh2[h[t]], h[0] == h0}, h, {t, 0, 10}, 
     EvaluationMonitor :> ++evals]; // AbsoluteTiming

Oddly, adding EvaluationMonitor to @xzczd's method increased the time by a huge factor (it took twice as long as mine), so I retimed it without the monitor, where @xzczd's took half the time mine did. These were done with a corrected ds.

One can see that dh2 evaluates about twice as fast, counted per evaluation, than @xzczd's method and 100 times faster than the OP's. Whether that is an entirely fair comparison depends on how much evaluating the ODE accounts for the execution time of NDSolve. It should account for a lot of it, but that's just my guess.

Area preserving?

I figure I should share this. If I made a mistake, well, someone can point it out. If not, then, maybe it will help the OP. If we consider what it means to be area-preserving, we should consider the integral $$A = \int_{-\pi}^\pi \text{$1\over2$}\, h(t,\theta)^2\;d\theta \,,$$ where $h$ is extended to $-\pi \le \theta \le \pi$ by defining $h(t,\theta) = 2$ (that is, the greater radius) outside $-5\pi/6 \le \theta \le -\pi/6$. Then, by my lights, differentiating under the integral sign, the rate of change of the area is given by $${dA \over dt} = \int_{-\pi}^\pi h(t,\theta)h_t(t,\theta)\;d\theta$$ and $h_t$ can be written in terms of $h$, $h_\theta$, $h_{\theta\theta}$ using the PDE.

Of course, an equilibrium solution will preserve area. But if we perturb an equilibrium solution, then $dA/dt$ is nonzero:

ClearAll[dhdt, dAdt];
Block[{h, θ},
 dhdt[h_, θ_] = -D[(h[θ] - 2)^2 (h[θ] - 1)^2 D[h[θ] Sin[θ], θ], θ];
 ];
dAdt[hfn_] := NIntegrate[hfn[θ] dhdt[hfn, θ], {θ, -Pi, Pi}];

(* background *)
θ1 = -2.4539664700963293`;
background = Show[
   RegionPlot[1 <= x^2 + y^2 <= 4, {x, -2, 2}, {y, -2, 2}, 
    PlotStyle -> Opacity[0.1], AspectRatio -> 1],
   PolarPlot[
    2 Sin[θ1]/Sin[θ], {θ, θ1, -(Pi + θ1)}, 
    PlotStyle -> Black]
   ];

solPlot[hfn_] := Show[
   background,
   PolarPlot[hfn, {θ, -5/6 π, -π/6},
    ColorFunction -> (ColorData["RedGreenSplit"][
        0.5 (1 + Clip[100 dhL /. h -> Function @@ {θ, hfn} /. θ -> #3, {-1,1}])] &),
    ColorFunctionScaling -> False,
    PlotRange -> {{-2, 2}, {-2, 2}}]
   ];

Block[{Print, θ2 = θ1, eps = +0.1, hf},
 hf = Piecewise[{
     {2 Sin[θ2] Csc[#] + eps (# - θ2) (# + Pi + θ2), θ2 < # < -Pi - θ2}
     }, 2] &;
 Show[solPlot[hf[θ]], PlotLabel -> Row[{"dA/dt = ", dAdt[hf]}]]
 ]

(Red means the radius h is decreasing; green means it is increasing (with respect to time in the DE.)

The effect of finite differences and the error in ds

Using Block and the OP's definition of dh, we can see what happens when we use different values for ds. There is some controversy about the correct value for ds, and it is my view that it should be equal to the differences in s. The padding by 2 on either side of h in for ListCorrelate[] in the OP's dh[] corresponds to using s == -5 Pi/ 6 - ds and s == -Pi / 6 + ds and corresponds to the (unused) condition that h is identically equal to 2 outside the interval {-5 Pi/6, -Pi/6}.

If we plot dh[h[s]], where h is the equilibrium solution of the OP, h[s] = 2 Sin[θ1] Csc[s] for a given θ1, and s is the input grid as above, we will see how close to zero the value of dh is for the finite difference scheme.

ClearAll[dhEquilPlot];
SetAttributes[dhEquilPlot, Listable];
θ1 = -2.4539664700963293`;
dhEquilPlot[ds0_] := Block[{ds = ds0},
  ListPlot[
   dh[Clip[2 Sin[θ1] Csc[s], {0., 2.}]],
   PlotLabel -> Row[{"ds = ", ds}], Frame -> True, 
   FrameLabel -> {HoldForm[s], HoldForm[h'[t]]}, DataRange -> MinMax[s], 
   BaseStyle -> {FractionBoxOptions -> {Beveled -> True}}
   ]
  ]

dhEquilPlot /@ {
   {1/n},                               (* OP     (UL) *)
   {(-(π/6) - -((5 π)/6))/(n + 2 - 1),  (* xzczd  (LL) *)
    (-(π/6) - -((5 π)/6))/(n - 1)}      (* M E2   (LR) *)
   } // GraphicsGrid

We can see how much closer to zero dh is for ds = Pi/300, which is also the grid spacing in s. It is also clear that in all three cases, the radius h is pulled toward the center (dh < 0) near where the level of the fluid contacts the outside circle (where h reaches 2). Of course the actual evolution from the OP's starting configuration will be slightly different. But since physically, the model should be area-preserving, there is little point in exploring this beyond determining the value of ds until the issue with area is cleared up.

Answer 2

Since a fully NDSolve-based solution is acceptable for you, let me give you one. You simply need the magic of "Pseudospectral" or a dense enough 4th order spatial discretization:

mol[n_, o_:"Pseudospectral"] := {"MethodOfLines", 
  "SpatialDiscretization" -> {"TensorProductGrid", "MaxPoints" -> n, 
    "MinPoints" -> n, "DifferenceOrder" -> o}}

ic[θ_] = Piecewise[{{1.001, -2 Pi/3 < θ < -Pi/3}}, 1.999];

(* Solution 1 *)    
sol = NDSolveValue[{pde, h[-5 π/6, t] == 1.999, h[-π/6, t] == 1.999, 
   h[θ, 0] == ic@θ}, h, {θ, -5 π/6, -π/6}, {t, 0, 10}, Method -> mol[101]]

(* Solution 2, NDSolveValue will spit out eerri warning but it doesn't matter. *)
sol2 = NDSolveValue[{pde, h[-5 π/6, t] == 1.999, h[-π/6, t] == 1.999, 
    h[θ, 0] == ic@θ}, h, {θ, -5 π/6, -π/6}, {t, 0, 10}, 
   Method ->mol[400, 4]];

pic = RegionPlot[1 <= x^2 + y^2 <= 4, {x, -2, 2}, {y, -2, 2}, PlotStyle -> Opacity[0.1]];

ListAnimate@Table[Show[PolarPlot[sol[θ, t], {θ, -5 π/6, -π/6}, 
  PlotRange -> 2, PlotStyle -> Black], pic], {t, 0, 10, 0.1}]

ListAnimate@Table[Show[PolarPlot[sol2[θ, t], {θ, -5 π/6, -π/6}, 
  PlotRange -> 2, PlotStyle -> Black], pic], {t, 0, 10, 0.1}]

OK, now the remaining problem is what's wrong with the FD scheme. Somewhat awkwardly, I found the root of evil is actually a simple mistake: the definition of ds should be

ds = (-(π/6) - -((5 π)/6))/(n - 1)

With this line corrected, your code outputs desired result, too.

Another thing I want to mention is, though (it's surprising to me that) NDSolve still manages to handle implicit vector in your case, it's much faster to define the list of unknown functions explicitly. The following approach is about 180 times faster than yours:

Clear@h;
sol = With[{h = h[#][t] & /@ Range@n}, 
    NDSolveValue[{D[h, t] == dh[h], (h /. t -> 0) == h0}, 
     Head /@ h, {t, 0, 10}]]; // AbsoluteTiming
(* {0.770651, Null} <- on contrast your approach takes about 140 seconds on my laptop*)


valh = Transpose[#["ValuesOnGrid"] & /@ sol];
ti = Flatten@sol[[1]]["Grid"];
s = Array[# &, n, {-5/6 π, -π/6}];

h = ListInterpolation[valh, {ti, s}]; // AbsoluteTiming
(* {0.860209, Null} *)