9
The bottleneck is in evaluating u. Compare:
Map[Eigenvalues[u[#]] &, N@w]; // AbsoluteTiming
(* Out[1437]= {11.4827, Null} *)
Map[u, N@w]; // AbsoluteTiming
(* Out[1438]= {9.57558, Null} *)
Compiling u can remove that bottleneck.
u2 = Compile[{{x, _Real}}, Evaluate[u[x]]];
Map[u2, N@w]; // AbsoluteTiming
Map[Eigenvalues[u2[#]] &, N@w]; // ...
7
First of all, the NDSolve solution can be further improved:
k = 5.;
tf = 3.;
c[θ1_?NumericQ, θ2_?NumericQ] :=
NIntegrate[(Sin[θ1 + t]^2. Cos[θ2 + t])/E^t, {t, 0., tf},
Method -> {Automatic, SymbolicProcessing -> 0}];
sol = NDSolve[{θ1'[t] == θ2[t]/E^(Sin[t]/10.) + c[θ1[t], θ2[t]],
θ2'[t] == -k Sin[θ1[t]]/E^(Sin[t]/10.),
...
6
Note: As pointed out by @DanielHuber in the comments, my original approach was assuming uniform distribution of the target points along the line instead of uniform distribution of the angles. Here's a corrected version: (the old answer is below)
Updated answer
We can solve this analytically by integrating:
func[x_, y_] = Assuming[0 < x < 1 && 0 ...
6
If we reduce the dataset to work with (you are only interested in the 5th an 16th atom and this will help your RAM problems) and compile the whole algorithm into something which is still readable but more compact, then we land an around x27 speed improvement.
dataDistances = Compile[{{dat, _Real, 4}}, Module[
{m, count, res, a, d, b, e, c, f, dist},
m = ...
5
Exact root-finding is very fast here:
bestRate[n_, numSteps_] := Module[{ii,h,hh,H,M,x0,xn,α},
ii = IdentityMatrix[n];
h = 1/Range[n];
hh = h~KroneckerProduct~h;
H = DiagonalMatrix[h];
M = ii - 2 α H + 2 α^2 H . H + α^2 hh;
x0 = ConstantArray[1, {n}];
xn = MatrixPower[M, numSteps] . x0;
Last@SolveValues[Expand[D[xn . h, α]] == 0, α, Reals]]
...
4
We can reduce computational time by 6 times with using compiled version of Distanceas follows
disc = Compile[{{r1, _Real, 1}, {r2, _Real,
1}}, \[Sqrt](If[Abs[r1[[1]] - r2[[1]]] >= 20,
Abs[r1[[1]] - r2[[1]]] - 40, Abs[r1[[1]] - r2[[1]]]]^2 +
If[Abs[r1[[2]] - r2[[2]]] >= 20, Abs[r1[[2]] - r2[[2]]] - 40,
Abs[r1[[2]] - r2[[2]]]]^2 +...
4
Could do it recursively, using FindRoot with starting point determined by previous value (per comment by @CraigCarter).
ff[3] = 1;
ff[n_Integer] :=
ff[n] = Floor[
s /. FindRoot[
Sum[((i - 1)/i)^s, {i, 2, n}] == n*10^(-6), {s, ff[n - 1]},
WorkingPrecision -> Log[2, n] + $MachinePrecision]]
Check result:
ListPlot[Table[ff[n], {n, 3, 100}]]
3
We can also using GSL via LibraryLink, almost ten times faster than before.
LaunchKernels[];
ParallelMap[roots, Tuples[N@{-1, 1}, 15]]; // RepeatedTiming
{1.1, Null}
gslRoots@Tuples[N@{-1, 1}, 15]; // RepeatedTiming
{0.12, Null}
It only takes about 3 minutes to calculate the roots of all polynomial equations of degree 24 with a coefficient of ±1.
For ...
3
For me, using Simplify when calculating xn greatly reduced the time for minimization. It was clear from using AbsoluteTiming that the majority of time was spent during minimization for your use case.
Original code ran in 6.4 seconds with n=5 and s=10. For the same parameters, the following code ran in 0.84 seconds for me. I'm sure there are more quick ...
2
Lists in Wolfram Language are simple linear arrays in memory. Such arrays, especially packed numeric arrays, are amenable to numerous optimizations all the way from the C compiler through to the hardware: on-chip CPU caching, speculative evaluation, pipelining, etc.
Associations in Wolfram Language are implemented using hash array mapped tries. This is a ...
1
The issue is that the compiled function is never actually used, combined with the fact that the printing of the message takes a bit of time:
(* Baseline *)
m1[z_] := {{1, z}, {2*z, z^2}};
Integrate[m1[z], {z, 0, 1}] // AbsoluteTiming
(* {0.0000917, {{1, 1/2}, {1, 1/3}}} *)
(* Your attempt *)
m2 = Compile[{{z, _Real}}, Evaluate@m1[z]];
Integrate[m2[z], {z, 0,...
1
You may use the Patterns Guide with Attributes and Orderless to identify functions whose parameters can be swapped.
ClearAll[swappableParams]
Options[swappableParams] = {Method -> "Verbose", Indexed -> False};
swappableParams[expr_, OptionsPattern[swappableParams]] :=
Module[{pos, paramsets},
pos = Position[
h_[p__] /; ContainsAny[...
1
Two functions that work with expressions that are FullSimplifyed as input:
ClearAll[swappableVariablesIn]
swappableVariablesIn[expr_] := Module[{vl = Variables[Level[expr, {-1}]],
foo = Module[{f = {#, #2} \[Function] Evaluate @ expr}, f[#, #2] === f[#2, #]] &},
Gather[vl, foo]]
ClearAll[swappableVariablesIn2]
swappableVariablesIn2[expr_] := ...
1
Maybe use NMaximize.
n = 4;
A = Table[Indexed[x, {i, j}], {j, 1, n}, {i, 1, n}];
vars = Flatten[A];
solns = NMaximize[{Det[A], 1 <= vars <= n, vars ∈ Integers,
Plus @@ vars == n*Plus @@ Range[n], Times @@ vars == (n!)^n},
vars][[2]]
A /. solns
A /. solns // Transpose
{{3, 4, 1, 2}, {3, 1, 3, 3}, {1, 4, 2, 4}, {1, 2, 4, 2}}
{{3, 3, 1, 1}, {4, ...
1
Note you can use SatisfiabilityInstances[expression, vars, All] to obtain all solutions, but if your specific property is common enough this is indeed inefficient. In this case, a better approach would be to use a randomized algorithm, e.g. try running a few times
FindInstance[expression, vars, Booleans, RandomSeeding -> Automatic]
However, this may or ...
Only top voted, non community-wiki answers of a minimum length are eligible
