Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Equation Solving sorted by activeGet numerical solution of PDE for diffusion at high diffusion rates?
https://community.wolfram.com/groups/-/m/t/1575334
I am trying to solve numerically the following PDE with IC and BCs as shown for u(t,x).
\[PartialD]u/\[PartialD]t = \[PartialD]^2u/\[PartialD]x^2 + p Subscript[(\[PartialD]u/\[PartialD]x), x=0]\[PartialD]u/\[PartialD]x
t = 0, u= 0
x= 0, u= 1
x = 1, u = 0
This equation arises in binary diffusion of a species where the diffusion rates are large as opposed to low rates where the second term on the RHS is very small and the PDE becomes identical to the heat conduction equation. This second term accounts for the convective flow induced by the diffusing species. The parameter p is related to the surface concentration of the diffusing species (at x = 0). A closed form solution is available for the case of a semi-infinite region where the last BC becomes x = \[Infinity], u = 0.
I tried to use NDSolve and NDSolveValue (code shown below) but I got an error message:
NDSolveValue::delpde: Delay partial differential equations are not currently supported by NDSolve.
I am unsure if there is (1)a mistake in the code, (2) code is correct but NDSolve cannot provide a solution, or (3) there is a different approach that will work. Would appreciate any help. Thanks.
usolh = NDSolveValue[{D[u[t, x], t] ==
D[u[t, x], x, x] + 0.5*(D[u[t, x], x] /. x -> 0)*D[u[t, x], x],
u[0, x] == 0, u[t, 0] == 1, u[t, 1] == 0},
u, {t, 0, 5}, {x, 0, 1}](*we are assuming p=0.5 here*)Rutton D Patel2018-12-20T03:09:22ZSolve analytically 1D transport equation?
https://community.wolfram.com/groups/-/m/t/1589719
I'm trying to solve for the analytical solution of 1D transport equation to verify the results of the numerical solution.
eqn = D[u[x, t], t] == D[u[x, t], {x, 2}];
ic = u[x, 0] == 50;
bc1 = u[0, t] == 50;
bc2 = D[u[1, t], x] == 0;
DSolve[{eqn, ic, bc1, bc2}, u[x, t], {x, t}]
However, I obtain the following,
DSolve::deqn: Equation or list of equations expected instead of True in the first argument {(u^(0,1))[x,t]==(u^(2,0))[x,t],u[x,0]==50,u[0,t]==50,True}.
Have I missed any step? I'm looking for the symbolic solution of the PDE with Dirichlet boundary condition at the inlet and Neumann boundary condition at the outlet.
Could someone help?Natash A2019-01-14T07:51:09ZStore variables after using Solve?
https://community.wolfram.com/groups/-/m/t/1592537
Hello everyone, I'm new here and new to Mathematica, very excited about it.
I have two questions:
1)is there a way to store variables after a Solve operation? For example a=Solve[x+1==0,x]
2)solving this gives me troubles: Solve[s^2+s+1==0,s] result s -> -(-1)1/3}, {s -> (-1)2/3}. Correct result are two complex conjugate radixes, is that a sort of module+phase writing? If so is there a way to obtain arithmetic format?
Using the domain field Solve[s^2+s+1==0,s,Complexes] doesn't help. The thing I do not understand further is that if I solve a*s^2 +b*s +c==0 it gives be the classical 2nd order formula and if then I substitute a=b=c=1 then I get the correct complex radixes in arithmetic form!
Thanks.Ermanno Citraro2019-01-15T11:18:23ZObtain a numerical solution and Plot this equation?
https://community.wolfram.com/groups/-/m/t/1578585
I found equations of motion for my generalized coordinates which are "Phi" and "l" , but I can not get numeric solutions and plots for them.Could you help me please?
z1 = (-R*W*Sin[\[Theta]] + l'[t]*Sin[\[Phi][t]] +
l*\[Phi]'[t]*Cos[\[Phi][t]] - R*W*Cos[\[Theta]] +
l'[t]*Cos[\[Phi][t]] - l*\[Phi]'[t]*Sin[\[Phi][t]]);
z1^2 // Expand // TrigReduce;
V = -m*g*(-R*Sin[\[Theta]] + l[t]*Cos[\[Phi][t]]) +
1/2*k*(l[t] - l0)^2;
T = 1/2*m*z1^2 // Expand // TrigReduce;
Lagrange = T - V;
eqs = D[D[Lagrange, \[Phi]'[t]], t] - D[Lagrange, \[Phi]] // Expand //
TrigReduce;
eqs2 = D[D[Lagrange, l'[t]], t] - D[Lagrange, l] // Expand //
TrigReduceĂ–mer Faruk AKYILDIZ2018-12-27T19:27:52ZSolve the Extended Generalized Bivariate Meijer G Function (EGBMGF)?
https://community.wolfram.com/groups/-/m/t/1564744
Hi everyone,
I am currently working on RF/FSO transmission systems. As a solution in the analytic expression, I obtained Extended Generalized Bivariate Meijer G Function (EGBMGF). To my best knowledge, the EGBMGF is not available in standard mathematical packages. How can I solve the problem numerically by using wolfram mathematica? How to calculate EGBMGF in mathematics? I deliver the analytical term of EGBMGF.
![enter image description here][1]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=EGBMGF.jpg&userId=1564710Marko Smilic2018-12-03T13:53:30ZSolve the Karush-Kuhn-Tucker equations with Reduce
https://community.wolfram.com/groups/-/m/t/1402471
Some years ago I published a short article in the Mathematica Journal describing solving the Karush-Kuhn-Tucker equations with Reduce, to do symbolic optimization. I was pleased to see that the approach subsequently used by several people. However, the code in that article has the problem that it gives all local minima. I've recently updated the code to only give global minima. The new code has the advantage over Minimize that it gives multiple global minima and also provides the values of the Lagrange multipliers, which give the sensitivity of the objective function to changes in the constraints. The code is shown below with copious comments. I've also given two examples in which the code returns a result but Minimize does not, even though this is an unusual circumstance.
Code
In[1]:= (* Generate the Karush-Kuhn-Tucker Equations *)
KTEqs[obj_ (* objective function *), cons_List (* constraints *), vars_List (*
variables *)] :=
Module[{consconvrule = {GreaterEqual[x_, y_] -> LessEqual[y - x, 0],
Equal[x_, y_] -> Equal[x - y, 0],
LessEqual[x_, y_] -> LessEqual[x - y, 0],
LessEqual[lb_, x_, ub_] -> LessEqual[(x - lb) (x - ub), 0],
GreaterEqual[ub_, x_, lb_] -> LessEqual[(x - lb) (x - ub), 0]} ,
x, y, lb, ub , stdcons, eqcons, ineqcons, lambdas, mus, lagrangian, eqs1,
eqs2, eqs3, alleqns, allvars },
(* Change constraints to Equal and LessEqual form with zero on the right-
hand side *)
stdcons = cons /. consconvrule;
(* Separate the equality constraints and the inequality constraints *)
eqcons = Cases[stdcons, Equal[_, 0]][[All, 1]];
ineqcons = Cases[stdcons, LessEqual[_, 0]][[All, 1]];
(* Define the Lagrange multipliers for the equality and inequality \
constraints *)
lambdas = Array[\[Lambda], Length[eqcons]];
mus = Array[\[Mu], Length[ineqcons]];
(* Define the Lagrangian *)
lagrangian = obj + lambdas.eqcons + mus.ineqcons;
(* The derivatives of the Lagrangian are equal to zero *)
eqs1 = Thread[ D[lagrangian, {vars}] == 0];
(* Lagrange multipliers for inequality constraints are \[GreaterEqual]0 to \
get minima *)
eqs2 = Thread[mus >= 0];
(* Lagrange multipliers for inequality constraints are 0 unless the \
constraint value is 0 *)
eqs3 = Thread[mus*ineqcons == 0];
(* Collect the equations *)
alleqns = Join[eqs1, eqs2, eqs3, cons];
(* Collect the variables *)
allvars = Join[vars, lambdas, mus];
(* Return the equations and the variables *)
{alleqns, allvars}
]
In[2]:= (* Convert logical expressions to rules *)
torules[res_] := If[Head[res] === And, ToRules[res], List @@ (ToRules /@ res)]
In[3]:= (* Find the global minima *)
KKTReduce[obj_(* objective function *), cons_List (* constraints *),
vars_List (* variables *)] :=
Block[{kkteqs, kktvars, red, rls, objs, allres, minobj, sel, ret, minred,
minredrls},
(* Construct the equations and the variables *)
{kkteqs, kktvars} = KTEqs[obj, cons, vars];
(* Reduce the equations *)
red = LogicalExpand @
Reduce[kkteqs, kktvars, Reals, Backsubstitution -> True];
(* Convert the Reduce results to rules (if possible ) *)
rls = torules[red];
(* If the conversion to rules was complete *)
If[Length[Position[rls, _ToRules]] == 0,
(* Calculate the values of the objective function *)
objs = obj /. rls;
(* Combine the objective function values with the rules *)
allres = Thread[{objs, rls}];
(* Find the minimum objective value *)
minobj = Min[objs];
(* Select the results with the minimum objective value *)
sel = Select[allres, #[[1]] == minobj &];
(* Return the minimum objective value with the corresponding rules *)
ret = {minobj, sel[[All, 2]]},
(* Else if the results were not completely converted to rules *)
(* Use MinValue to find the smallest objective function value *)
minobj = MinValue[{obj, red}, kktvars];
(* Use Reduce to find the corresponding results *)
minred =
Reduce[obj == minobj && red, kktvars, Reals, Backsubstitution -> True];
(* Convert results to rules, if possible *)
minredrls = torules[minred];
ret = If[
Length[Position[minredrls, _ToRules]] == 0, {minobj, minredrls}, {minobj,
minred}];
];
(* Remove excess nesting from result *)
If[Length[ret[[2]]] == 1 && Depth[ret[[2]]] > 1, {ret[[1]], ret[[2, 1]]},
ret]
]
In[4]:=
Examples
In[5]:= Minimize[{x^2 - y^2, Cos[x - y] >= 1/2, -5 <= x <= 5, -5 <= y <= 5}, {x, y}]
Out[5]= Minimize[{x^2 - y^2, Cos[x - y] >= 1/2, -5 <= x <= 5, -5 <= y <= 5}, {x, y}]
In[6]:= KKTReduce[x^2 - y^2, {Cos[x - y] >= 1/2, -5 <= x <= 5, -5 <= y <= 5}, {x, y}]
Out[6]= {-25 + 25/9 (-3 + \[Pi])^2, {{x -> -(5/3) (-3 + \[Pi]),
y -> 5, \[Mu][1] -> (20 (-3 + \[Pi]))/(3 Sqrt[3]), \[Mu][2] ->
0, \[Mu][3] ->
1/9 (9 + 6 Sqrt[3] Sin[5 + 5/3 (-3 + \[Pi])] -
2 Sqrt[3] \[Pi] Sin[5 + 5/3 (-3 + \[Pi])])}, {x -> 5/3 (-3 + \[Pi]),
y -> -5, \[Mu][1] -> (20 (-3 + \[Pi]))/(3 Sqrt[3]), \[Mu][2] ->
0, \[Mu][3] ->
1/9 (9 + 6 Sqrt[3] Sin[5 + 5/3 (-3 + \[Pi])] -
2 Sqrt[3] \[Pi] Sin[5 + 5/3 (-3 + \[Pi])])}}}
In[7]:= TimeConstrained[
Minimize[{(Subscript[x, 1] - Subscript[x, 2])^2 + (Subscript[x, 2] -
Subscript[x, 3])^4, (1 + Subscript[x, 2]^2) Subscript[x, 1] + Subscript[
x, 3]^4 - 3 == 0}, {Subscript[x, 1], Subscript[x, 2], Subscript[x,
3]}], 60]
Out[7]= $Aborted
In[8]:= AbsoluteTiming @
KKTReduce[(Subscript[x, 1] - Subscript[x, 2])^2 + (Subscript[x, 2] -
Subscript[x, 3])^4, {(1 + Subscript[x, 2]^2) Subscript[x, 1] + Subscript[
x, 3]^4 - 3 == 0}, {Subscript[x, 1], Subscript[x, 2], Subscript[x, 3]}]
Out[8]= {1.67203, {0, {{Subscript[x, 1] -> 1, Subscript[x, 2] -> 1,
Subscript[x, 3] -> 1, \[Lambda][1] -> 0}, {Subscript[x, 1] ->
AlgebraicNumber[Root[3 + 2 #1 + 2 #1^2 + #1^3 &, 1], {0, 1, 0}],
Subscript[x, 2] ->
AlgebraicNumber[Root[3 + 2 #1 + 2 #1^2 + #1^3 &, 1], {0, 1, 0}],
Subscript[x, 3] ->
AlgebraicNumber[
Root[3 + 2 #1 + 2 #1^2 + #1^3 &, 1], {0, 1, 0}], \[Lambda][1] -> 0}}}}Frank Kampas2018-08-11T17:18:58ZSolve a system of differential equations?
https://community.wolfram.com/groups/-/m/t/1581981
Hello. I need to solve differential equations system dh/dt=f(h) d^2h/dt^2=g(h), h=h(t)
Here is the code:
ksi = 1;
system = {h'[t] == ksi/2*((1/(h[t]*h[t] + 1/4)^3/2) - 1), h''[t] == -((1/(h[t]*h[t] + 1/4)^3/2) - 1)*h[t]};
sol = DSolve[system, {h[t]}, t];
Plot[Evaluate[{h[t]} /. sol], {t, -1, 10}, WorkingPrecision -> 20]
And it shows an error.
Could anybody fix this problem? Thanks a lot.Torebek Zhumabek2019-01-03T13:55:18Z