1
$\begingroup$

I recently tried to find a root with FindRoot in Mathematica. I know that the problem has a solution, but when using FindRoot, this error appears :

FindRoot::lstol: The line search decreased the step size to within tolerance specified by AccuracyGoal and PrecisionGoal but was unable to find a sufficient decrease in the merit function. You may need more than 10000.` digits of working precision to meet these tolerances. >> t->{0.1139}

However, I get an answer, but this is not a really accurate one! Even though I changed AccuracyGoal, PrecessionGoal and WorkingPrecession, the answer didn't change. Please help me getting rid of the error.

My code is:

a1 = 0.375;
a2 = 0.175;
b1 = 0.125;
b2 = 0.325;
m1 = 0.05;
m2 = 0.5;
mh = 0.5;
l1 = a1 + b1;
l2 = a2 + b2;
λ = 0.0504;
g = 9.81;
kinetic1 = 
  1/2 m1 (a1^2 Cos[q1[t]]^2 q1'[t]^2 + a1^2 Sin[q1[t]]^2 q1'[t]^2) + 
  1/2 m2 ((a2 Cos[q1[t]] q1'[t] + 
    l1 Cos[q1[t]] q1'[t])^2 + (-a2 Sin[q1[t]] q1'[t] - 
    l1 Sin[q1[t]] q1'[t])^2) + 
  1/2 mh ((l1 Cos[q1[t]] q1'[t] + 
    l2 Cos[q1[t]] q1'[t])^2 + (-l1 Sin[q1[t]] q1'[t] - 
    l2 Sin[q1[t]] q1'[t])^2) + 
  1/2 m2 ((l1 Cos[q1[t]] q1'[t] + l2 Cos[q1[t]] q1'[t] + 
    b2 Cos[q2[t]] q2'[t])^2 + (-l1 Sin[q1[t]] q1'[t] - 
    l2 Sin[q1[t]] q1'[t] - b2 Sin[q2[t]] q2'[t])^2) + 
  1/2 m1 ((l1 Cos[q1[t]] q1'[t] + l2 Cos[q1[t]] q1'[t] + 
    l2 Cos[q2[t]] q2'[t] + 
    b1 Cos[q3[t]] q3'[t])^2 + (-l1 Sin[q1[t]] q1'[t] - 
    l2 Sin[q1[t]] q1'[t] - l2 Sin[q2[t]] q2'[t] - 
    b1 Sin[q3[t]] q3'[t])^2);
potential1 = 
  m1 g (a1 Cos[q1[t]]) + m2 g ((l1 + a2) Cos[q1[t]]) + 
  mh g ((l1 + l2) Cos[q1[t]]) + 
  m2 g ((l1 + l2) Cos[q1[t]] - b2 Cos[q2[t]]) + 
  m1 g ((l1 + l2) Cos[q1[t]] - l2 Cos[q2[t]] - b1 Cos[q3[t]]);
lagrangeq11 = 
  D[D[kinetic1, q1'[t]], t] - D[kinetic1, q1[t]] + 
  D[potential1, q1[t]];
lagrangeq21 = 
  D[D[kinetic1, q2'[t]], t] - D[kinetic1, q2[t]] + 
  D[potential1, q2[t]];
lagrangeq31 = 
  D[D[kinetic1, q3'[t]], t] - D[kinetic1, q3[t]] + 
  D[potential1, q3[t]];
kinetic2 = 
  1/2 m1 (a1^2 Cos[q1[t]]^2 q1'[t]^2 + a1^2 Sin[q1[t]]^2 q1'[t]^2) + 
  1/2 m2 ((a2 Cos[q1[t]] q1'[t] + 
    l1 Cos[q1[t]] q1'[t])^2 + (-a2 Sin[q1[t]] q1'[t] - 
    l1 Sin[q1[t]] q1'[t])^2) + 
  1/2 mh ((l1 Cos[q1[t]] q1'[t] + 
    l2 Cos[q1[t]] q1'[t])^2 + (-l1 Sin[q1[t]] q1'[t] - 
    l2 Sin[q1[t]] q1'[t])^2) + 
  1/2 m2 ((l1 Cos[q1[t]] q1'[t] + l2 Cos[q1[t]] q1'[t] + 
    b2 Cos[q2[t]] q2'[t])^2 + (-l1 Sin[q1[t]] q1'[t] - 
    l2 Sin[q1[t]] q1'[t] - b2 Sin[q2[t]] q2'[t])^2) + 
  1/2 m1 ((l1 Cos[q1[t]] q1'[t] + l2 Cos[q1[t]] q1'[t] + 
    l2 Cos[q2[t]] q2'[t] + 
    b1 Cos[q2[t]] q2'[t])^2 + (-l1 Sin[q1[t]] q1'[t] - 
    l2 Sin[q1[t]] q1'[t] - l2 Sin[q2[t]] q2'[t] - 
    b1 Sin[q2[t]] q2'[t])^2);
potential1 = 
  m1 g (a1 Cos[q1[t]]) + m2 g ((l1 + a2) Cos[q1[t]]) + 
  mh g ((l1 + l2) Cos[q1[t]]) + 
  m2 g ((l1 + l2) Cos[q1[t]] - b2 Cos[q2[t]]) + 
  m1 g ((l1 + l2) Cos[q1[t]] - l2 Cos[q2[t]] - b1 Cos[q2[t]]);
lagrangeq12 = 
  D[D[kinetic2, q1'[t]], t] - D[kinetic2, q1[t]] + 
  D[potential2, q1[t]];
lagrangeq22 = 
  D[D[kinetic2, q2'[t]], t] - D[kinetic2, q2[t]] + 
  D[potential2, q2[t]];
q10 = -0.1877 - λ;
q30 = q20 = 0.2884 - λ;
q1d0 = 1.1014;
q3d0 = q2d0 = 0.0399;
beforeknee1 = {{0, q10}}; beforeknee2 = {{0, q20}}; beforeknee3 = {{0,
    q30}};
time = timep = 0;
Clear[v1];
Clear[v2];
lagrangesolveg1 = 
  NDSolve[{lagrangeq11 == 0, lagrangeq21 == 0, lagrangeq31 == 0, 
  q1[0] == q10, q2[0] == q20, q3[0] == q20, q1'[0] == q1d0, 
  q2'[0] == q2d0, q3'[0] == q2d0}, {q1, q3, q2}, {t, 0, 1}, 
  MaxSteps -> 1000000];
time1 = FindRoot[(q3[t] == q2[t]) /. lagrangesolveg1, {t, 0.5, 0, 
  1}]; time1 = t /. time1; time1 = SetAccuracy[time1, 5];
For[τ = 1, τ < (IntegerPart[10000 time1] + 1), τ++, 
  q1t = q1[τ/10000] /. lagrangesolveg1; 
  q2t = q2[τ/10000] /. lagrangesolveg1; 
  q3t = q3[τ/10000] /. lagrangesolveg1; 
time = N[timep + τ/10000]; 
beforeknee1 = Append[beforeknee1, {time, q1t[[1]]}]; 
beforeknee2 = Append[beforeknee2, {time, q2t[[1]]}]; 
beforeknee3 = Append[beforeknee3, {time, q3t[[1]]}];];
timep = time;
hh1 = q1'[time1] /. lagrangesolveg1;
hh1 = hh1[[1]];
hh2 = q2'[time1] /. lagrangesolveg1;
hh2 = hh2[[1]];
hh3 = q3'[time1] /. lagrangesolveg1;
hh3 = hh3[[1]];
hh4 = q1[time1] /. lagrangesolveg1;
hh4 = hh4[[1]];
hh5 = q3[time1] /. lagrangesolveg1;
hh5 = hh5[[1]];
kneeright1 = 
  Cross[{a1 Sin[hh4], a1 Cos[hh4], 0}, 
  m1 {a1 Cos[hh4] v1, -a1 Sin[hh4] v1, 0}] + 
  Cross[{(a2 + l1) Sin[hh4], (a2 + l1) Cos[hh4], 0}, 
  m2 {a2 Cos[hh4] v1 + l1 Cos[hh4] v1, -a2 Sin[hh4] v1 - 
   l1 Sin[hh4] v1, 0}] + 
  Cross[{(l2 + l1) Sin[hh4], (l2 + l1) Cos[hh4], 0}, 
  mh {l1 Cos[hh4] v1 + l2 Cos[hh4] v1, -l1 Sin[hh4] v1 - 
   l2 Sin[hh4] v1, 0}] + 
  Cross[{(l2 + l1) Sin[hh4] - b2 Sin[hh5], (l2 + l1) Cos[hh4] - 
   b2 Cos[hh5], 0}, 
  m2 {l1 Cos[hh4] v1 + l2 Cos[hh4] v1 + 
   b2 Cos[hh5] v2, -l1 Sin[hh4] v1 - l2 Sin[hh4] v1 - 
   b2 Sin[hh5] v2, 0}] + 
  Cross[{(l2 + l1) Sin[hh4] - l2 Sin[hh5] - 
   b1 Sin[hh5], (l2 + l1) Cos[hh4] - l2 Cos[hh5] - b1 Cos[hh5], 0},
  m1 {l1 Cos[hh4] v1 + l2 Cos[hh4] v1 + l2 Cos[hh5] v2 + 
   b1 Cos[hh5] v2, -l1 Sin[hh4] v1 - l2 Sin[hh4] v1 - 
   l2 Sin[hh5] v2 - b1 Sin[hh5] v2, 0}];
kneeleftt1 = 
  Cross[{a1 Sin[hh4], a1 Cos[hh4], 0}, 
  m1 {a1 Cos[hh4] hh1, -a1 Sin[hh4] hh1, 0}] + 
  Cross[{(a2 + l1) Sin[hh4], (a2 + l1) Cos[hh4], 0}, 
  m2 {a2 Cos[hh4] hh1 + l1 Cos[hh4] hh1, -a2 Sin[hh4] hh1 - 
   l1 Sin[hh4] hh4, 0}] + 
  Cross[{(l2 + l1) Sin[hh4], (l2 + l1) Cos[hh4], 0}, 
  mh {l1 Cos[hh4] hh1 + l2 Cos[hh4] hh1, -l1 Sin[hh4] hh1 - 
   l2 Sin[hh4] hh1, 0}] + 
  Cross[{(l2 + l1) Sin[hh4] - b2 Sin[hh5], (l2 + l1) Cos[hh4] - 
   b2 Cos[hh5], 0}, 
  m2 {l1 Cos[hh4] hh1 + l2 Cos[hh4] hh1 + 
   b2 Cos[hh5] hh2, -l1 Sin[hh4] hh1 - l2 Sin[hh4] hh1 - 
   b2 Sin[hh5] hh2, 0}] + 
  Cross[{(l2 + l1) Sin[hh4] - l2 Sin[hh5] - 
  b1 Sin[hh5], (l2 + l1) Cos[hh4] - l2 Cos[hh5] - b1 Cos[hh5], 0},
  m1 {l1 Cos[hh4] hh1 + l2 Cos[hh4] hh1 + l2 Cos[hh5] hh2 + 
   b1 Cos[hh5] hh3, -l1 Sin[hh4] hh1 - l2 Sin[hh4] hh1 - 
   l2 Sin[hh5] hh2 - b1 Sin[hh2] hh3, 0}];
 kneeright2 = 
  Cross[{-b2 Sin[hh5], -b2 Cos[hh5], 0}, 
  m2 {l1 Cos[hh4] v1 + l2 Cos[hh4] v1 + 
   b2 Cos[hh5] v2, -l1 Sin[hh4] v1 - l2 Sin[hh4] v1 - 
   b2 Sin[hh5] v2, 0}] + 
  Cross[{-l2 Sin[hh5] - b1 Sin[hh5], -l2 Cos[hh5] - b1 Cos[hh5], 0}, 
  m1 {l1 Cos[hh4] v1 + l2 Cos[hh4] v1 + l2 Cos[hh5] v2 + 
   b1 Cos[hh5] v2, -l1 Sin[hh4] v1 - l2 Sin[hh4] v1 - 
   l2 Sin[hh5] v2 - b1 Sin[hh5] v2, 0}];
 kneeleftt2 = 
  Cross[{-b2 Sin[hh5], -b2 Cos[hh5], 0}, 
  m2 {l1 Cos[hh4] hh1 + l2 Cos[hh4] hh1 + 
   b2 Cos[hh5] hh2, -l1 Sin[hh4] hh1 - l2 Sin[hh4] hh1 - 
   b2 Sin[hh5] hh2, 0}] + 
  Cross[{-l2 Sin[hh5] - b1 Sin[hh5], -l2 Cos[hh5] - b1 Cos[hh5], 0}, 
  m1 {l1 Cos[hh4] hh1 + l2 Cos[hh4] hh1 + l2 Cos[hh5] hh2 + 
   b1 Cos[hh5] hh3, -l1 Sin[hh4] hh1 - l2 Sin[hh4] hh1 - 
   l2 Sin[hh5] hh2 - b1 Sin[hh2] hh3, 0}];
 kneestrike = 
  Solve[{kneeleftt1 == kneeright1, kneeleftt2 == kneeright2}, {v1, 
   v2}];
{{v1, v2}} = {v1, v2} /. kneestrike;
lagrangesolveg2 = 
  NDSolve[{lagrangeq12 == 0, lagrangeq22 == 0, q1[0] == hh4, 
   q2[0] == hh5, q1'[0] == v1, q2'[0] == v2}, {q1, q2}, {t, 0, 1}, 
   MaxSteps -> 1000000];

time2 = FindRoot[(q1[t] == -q2[t]) /. lagrangesolveg2, {t, 0.5, 0, 1}]
$\endgroup$
1
3
$\begingroup$

There does not appear to be a solution. FindRoot gets as close as it can.

Plot[{q1[t], -q2[t]} /. lagrangesolveg2 // Evaluate, {t, 0, 1}]

Mathematica graphics

Plot[{q1[t], -q2[t]} /. lagrangesolveg2 // Evaluate, {t, 0.05, 0.2}]

Mathematica graphics

$\endgroup$
1
  • $\begingroup$ thank you very much, but this problem has been solved in literatures before this! then i must review my solution's procedure again and find where the problem is... . as in related papers, there must be a solution... $\endgroup$ – amirarshia Nov 19 '15 at 14:48

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.