Skip to main content

differential equations - Solving 2D+1 PDE with Pseudospectral in one direction with periodic boundary condition?


According to the documentation about the pseudospectral difference-order:


It says:


enter image description here


Following the discussion here:


I found the messy behavior is always on the artificial boundary in $\omega$-direction ($u(t,\theta,\omega_{cutoff})=0$ because I want $\omega$ to be unbounded.) Perhaps, this is so called Runge phenomenon? In principle, we should not use pseudospectral difference-order for all directions. However, it is not clear how to specify them separately.


Here is code:



a = 1;
T = 1;
ωb = -15; ωt = 15;
A = 8;
γ = .1;
kT = 0.1;
φ = 0;
mol[n_Integer, o_: "Pseudospectral"] := {"MethodOfLines",
"SpatialDiscretization" -> {"TensorProductGrid", "MaxPoints" -> n,
"MinPoints" -> n, "DifferenceOrder" -> o}}


With[{u = u[t,θ, ω]},
eq = D[u, t] == -D[ω u,θ] - D[-A Sin[3θ] u, ω] + γ (1 + Sin[3θ]) kT D[
u, {ω, 2}] + γ (1 + Sin[3θ]) D[ω u, ω];
ic = u == E^(-((ω^2 +θ^2)/(2 a^2))) 1/(2 π a) /. t -> 0];
ufun = NDSolveValue[{eq, ic, u[t, -π, ω] == u[t, π, ω],
u[t,θ, ωb] == 0, u[t,θ, ωt] == 0}, u, {t, 0, T}, {θ, -π, π}, {ω, ωb, ωt},
Method -> mol[61], MaxSteps -> Infinity]; // AbsoluteTiming
plots = Table[
Plot3D[Abs[ufun[t,θ, ω]], {θ, -π, π}, {ω, ωb, ωt}, AxesLabel -> Automatic,

PlotPoints -> 30, BoxRatios -> {Pi, ωb, 1},
ColorFunction -> "LakeColors", PlotRange -> All], {t, 0, T,
T/10}]; // AbsoluteTiming
ListAnimate[plots]

$t=0$


enter image description here


$t=0.8$


enter image description here


$t=0.9$



enter image description here


One can clearly see the large deviation occurs only in $\omega$-direction, which is consistent with the description as above (neither periodic nor Chebyshev).


Is it possible to have something like:


"DifferenceOrder" ->{"Pseudospectral", Automatic}

The above simply doesn't work.


Update: Finally, I figure out the problem is just due to convection-domination. The problem is depending on the ratio of convection term and diffusion term. Artificial diffusion or denser grid points is necessary.


Update(8/25): After using the implicit RungeKutta scheme, the solution is much stable. Now the another problem is the convergency.


What I expect is something similar to the following smooth behavior. enter image description here


But so far their is no such method which can arrive this, or? enter image description here




Answer



The computation in the question appears to suffer from a Courant instability. To illustrate, repeat the computation with higher plotting resolution and a slightly simpler code.


a = 1; T = 1; n = {61, 61};
ωb = -15; ωt = 15;
A = 8; γ = 1/10; kT = 1/10;
eq = D[u[t, θ, ω], t] == -D[ω u[t, θ, ω], θ] - D[-A Sin[3 θ] u[t, θ, ω], ω]
+ γ (1 + Sin[3 θ]) kT D[u[t, θ, ω], {ω, 2}] + γ (1 + Sin[3 θ]) D[ω u[t, θ, ω], ω];
ic = u[t, θ, ω] == E^(-((ω^2 + θ^2)/(2 a^2))) 1/(2 π a) /. t -> 0;
ufun = NDSolveValue[{eq, ic, u[t, -π, ω] == u[t, π, ω], u[t, θ, ωb] == 0,
u[t, θ, ωt] == 0}, u, {t, 0, T}, {θ, -π, π}, {ω, ωb, ωt},

Method -> {"MethodOfLines", "SpatialDiscretization" -> {"TensorProductGrid",
"MaxPoints" -> n, "MinPoints" -> n, "DifferenceOrder" -> "Pseudospectral"}}];
Plot3D[Abs[ufunot[.9, θ, ω]], {θ, -π, π}, {ω, ωb, ωt}, PlotPoints -> 2 n,
PlotRange -> All, BoxRatios -> {Pi, ωb, 1}, ColorFunction -> "LakeColors",
ImageSize -> Large, AxesLabel -> {θ, ω, u}, LabelStyle -> {Black, Bold, Medium},
Mesh -> None]

enter image description here


The higher plotting resolution displays significant fine structure in the numerical behavior near ω == ωt. A second plot focusing on that region makes the fine structure even more apparent.


Plot3D[Abs[ufun[T, θ, ω]], {θ, -π, π}, {ω, 12, ωt}, PlotPoints -> {122, 40}, 

PlotRange -> All, ImageSize -> Large, AxesLabel -> {θ, ω, u},
LabelStyle -> {Black, Bold, Medium}, Mesh -> None]

enter image description here


Spatial oscillations with wavelengths on the order of the cell size are the hallmark of the Courant instability. Reducing the number of grid points in ω from 61 to 59 to 57 steadily reduces the instability growth rate, and at 55 the instability disappears. Repeating the computation above with T = 10; n = {61, 55} shows no sign of the Courant instability.


enter image description here


There are, however, two obvious issues. First, waves have reached the boundaries in ω and appear to be reflecting. (The PDE is approximately advective at large Abs[ω].) Second, spatial resolution may no longer be sufficient to accurately represent the short wavelengths evident in the plot. The runtime for this computation was of order four minutes, and doubling the resolution would require over a half-hour of calculation, as well as some experimentation to find the optimal ratio of grid points in the two spatial dimensions. For completeness, here is a plot of the latter solution at T == 5, where the spatial resolution and boundary reflection problems are not yet significant.


enter image description here


Comments

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...