Skip to main content

differential equations - PDE with Stefan Conditions, a.k.a variable boundary


I want to solve the one-dimensional one-phase Stefan problem, but I don't know how to make Mathematica understand the conditions.


If you are not familiar with what I'm asking please refer to this wikipedia article: http://en.wikipedia.org/wiki/Stefan_problem#Mathematical_formulation


This is what I have so far. Clearly, it doesn't work.


NDSolve[
 {D[u[x, t], t] == D[u[x, t], {x, 2}],

  (-D[u[x, t], x] /. x -> 0) == 1,
  u[s[t], t] == 0,
  D[s[t]] == (-D[u[x, t], x] /. x -> s[t]),
  u[x, 0] == 0,
  s[0] == 0
  },
{u, s}, {x, 0, s[t]}, {t, 0, 10}]

I hope there is someone out there with a magical code


I'm using Mathematica 10.



Thanks!



Answer



One can do it semi-automatically. Let us introduce a normalized variable $$ \xi = \frac{x}{s(t)}, \quad \xi \in [0,1] $$ and make a simple finite difference method over $\xi$.


The differential equation in new variables is


ClearAll[u, s, x, t, ξ]
D[u[x/s[t], t], t] == D[u[x/s[t], t], x, x] /. x -> ξ s[t]

enter image description here


If we divide the interval $[0,1]$ by $n$ subintervals we come to the following finite difference scheme


n = 100;

δξ = 1./n;

ClearAll[dv, t];
dv[v_List] := With[{s = First@v, u = Rest@v},
   With[{ds = u[[-1]]/(s δξ),
     ξ = N@Range[n - 1]/n,
     d1 = ListCorrelate[{-0.5, 0, 0.5}/δξ, #] &,
     d2 = ListCorrelate[{1, -2, 1}/δξ^2, #] &},
    Prepend[d2[#]/s^2 + ξ ds d1[#]/s &@Join[{u[[1]] + s δξ}, u, {0.}], ds]
    ]];

s0 = 0.001;
v0 = Prepend[ConstantArray[0., n - 1], s0];
sol = NDSolve[{v'[t] == dv[v[t]], v[0] == v0}, v, {t, 0, 1}][[1, 1, 2]];

Here v contains s (the first element) and u (the rest list).


It remains only to decompose the interpolation function sol and return to the initial variable x


Needs@"DifferentialEquations`InterpolatingFunctionAnatomy`";
values = InterpolatingFunctionValuesOnGrid@sol;
valu = Transpose@Join[{#[[2]] + δξ #[[1]]}, Rest@#, {0 #[[1]]}] &@
   Transpose@InterpolatingFunctionValuesOnGrid@sol;

vals = InterpolatingFunctionValuesOnGrid[sol][[All, 1]];
t = Flatten@InterpolatingFunctionGrid@sol;
ξ = Range[0., n]/n;
s = ListInterpolation[vals, t];
uξ = ListInterpolation[valu, {t, ξ}];
u = If[#2 < s[#], uξ[#, #2/s[#]], 0.] &;

Visualization of the result


Show[{DensityPlot[u[t, x], {t, 0, 1}, {x, 0, 1}, FrameLabel -> {"t", "x"}], 
   Plot[s[t], {t, 0, 1}, PlotStyle -> {Red, Dashed}]}]


enter image description here


Comments

Post a Comment

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...
Post a Comment
Read more

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...
Post a Comment
Read more

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-...
Post a Comment
Read more