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 ω-direction (u(t,θ,ωcutoff)=0 because I want ω 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 ω-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...

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]