1
$\begingroup$

I am using an modified version of Wagon's FindAllCrossings2D[] function available here Updating Wagon's FindAllCrossings2D[] function. I am defining f[alpha,w] and g[alpha,w] as the real and imaginary part of function da[alpha,w] whose complex roots are to be evaluated.

(*Code for Roots Finding*)
(*Options[FindAllCrossings2D] = 
  Sort[Join[
    Options[FindRoot], {MaxRecursion -> Automatic, 
     PerformanceGoal :> $PerformanceGoal, PlotPoints -> Automatic}]];

FindAllCrossings2D[funcs_, {x_, xmin_, xmax_}, {y_, ymin_, ymax_}, 
  opts___] := 
 Module[{contourData, seeds, tt, 
   fy = Compile[{x, y}, Evaluate[funcs[[2]]]]}, 
  contourData = 
   Map[First, 
    Cases[Normal[
      ContourPlot[funcs[[1]], {x, xmin, xmax}, {y, ymin, ymax}, 
       Contours -> {0}, ContourShading -> False, 
       PlotRange -> {Full, Full, Automatic}, 
       Evaluate[
        Sequence @@ 
         FilterRules[Join[{opts}, Options[FindAllCrossings2D]], 
          DeleteCases[Options[ContourPlot], Method -> _]]]]], _Line, 
     Infinity]];
  seeds = 
   Flatten[Map[#[[
       1 + Flatten[
         Position[Rest[tt = Sign[Apply[fy, #, 2]]] Most[tt], -1]]]] &,
      contourData], 1];
  If[seeds == {}, seeds, 
   Select[Union[
     Map[{x, y} /. 
        FindRoot[{funcs[[1]] == 0, 
          funcs[[2]] == 0}, {x, #[[1]]}, {y, #[[2]]}, 
         Evaluate[
          Sequence @@ 
           FilterRules[Join[{opts}, Options[FindAllCrossings2D]], 
            Options[FindRoot]]]] &, 
      seeds]], (xmin < #[[1]] < xmax && ymin < #[[2]] < ymax) &]]]*)

(*Program For Sliding Control*)
Clear[sigma, sigmab, xib, cn, ct, a, l, ei, tau, pb, fb, fc, ks, aa,bb, k, lamda, xi, b, lp, w, alpha, da, an]
cn = 0.0034;
ct = 0.0017;
a = (0.185*10^(-6))/2;
l = 58.3*10^(-6);
ei = 1700*10^(-24) // N;
tau = 0.004;
pb = 0.03;
fb = 3.8*10^(-12) // N;
fc = 2*10^(-12) // N;
fp = 1.8*10^(-6) // N;
ks = 94.8*10^(-3) // N;
gama = 0.273*10^(-3) // N;
rho = 150*10^(6) // N;
k3 = 800*10^(12) // N;
aa = 2*rho*pb*(1 - pb)*fb*fp/fc;
bb = 2*rho*pb*fp;
k = -1620;
lamda = -7.60;
sigma[alpha_, w_] := alpha + I*w;
xi[alpha_, 
   w_] := (-aa*(alpha + I*w)/(1 + (alpha + I*w)*tau)) + (bb*(alpha + 
       I*w));
sigmab[alpha_, w_] := (alpha + I*w)*cn*l^4/ei ;
xib[alpha_, 
   w_] := ((-aa*(alpha + I*w)/(1 + (alpha + I*w)*tau)) + (bb*(alpha + 
         I*w)))*a^2*l^2/ei;
lp[alpha_, 
   w_] := ((-aa*(alpha + I*w)/(1 + (alpha + I*w)*tau)) + (bb*(alpha + 
         I*w)))*a^2*l^2/ei;
nomodes = 1;
(*Calculation of Elements of Matrix*)
b = {1.875, 4.694, 7.8548, 10.9955, 14.1372, 17.2788, 20.4204, 
   23.5619, 26.7035, 29.8451, 32.9867, 36.1283, 39.2699, 42.4115, 
   45.5531, 48.6947};
an = (-Sin[b] + Sinh[b])/(Cos[b] + Cosh[b]);
q = an*(Cos[b*x] - Cosh[b*x]) + (Sin[b*x] + Sinh[b*x]);
qx = D[q, x];
qxx = D[qx, x];
qxxx = D[qxx, x];
phi = an*(-Cos[b*x] - Cosh[b*x]) + (-Sin[b*x] + Sinh[b*x]);
phix = D[phi, x];
phixx = D[phix, x];
phixxx = D[phixx, x];
cm = Table[
   NIntegrate[phi[[i]]*q[[j]], {x, 0, 1}], {i, nomodes}, {j, nomodes}];
coeffMat[alpha_, w_] := Table[
  k1m = NIntegrate[phixx[[i]]*qxx[[j]], {x, 0, 1}];
  k2m = NIntegrate[phix[[i]]*qx[[j]], {x, 0, 1}];
  k3ma = phi[[i]]*qxxx[[j]] + phi[[i]]*lp[alpha, w]*qx[[j]] - 
     phix[[i]]*qxx[[j]] /. x -> 1;
  k3mb = phi[[i]]*qxxx[[j]] + phi[[i]]*lp[alpha, w]*qx[[j]] - 
     phix[[i]]*qxx[[j]] /. x -> 0;
  k3m = k3ma - k3mb;
  km = k1m + lp[alpha, w]*k2m + k3m, {i, nomodes}, {j, nomodes}]
da[alpha_, w_] = Det[coeffMat[alpha, w] + sigmab[alpha, w]*cm]
f[alpha_, w_] = Re[da[alpha, w]]
g[alpha_, w_] = Im[da[alpha, w]]
pts = FindAllCrossings2D[{f[alpha, w], g[alpha, w]}, {alpha, -100, 
    100}, {w, -400, 400}, 
   Method -> {"Newton", "StepControl" -> "LineSearch"}, 
   PlotPoints -> 85, WorkingPrecision -> 20] // Chop
ContourPlot[{f[alpha, w], g[alpha, w]}, {alpha, -100, 100}, {w, -400, 
  400}, Contours -> {0}, ContourShading -> False, 
 Epilog -> {AbsolutePointSize[6], Red, Point /@ pts}]

There are certain problems which I am facing

  • While calculating matrix form of coeffMat[alpha,w] using Table function its showing error $Failed
  • When using the FindAllCrossings2D[] it is unable to find the roots

    (I think the first error is leading to the failure in finding the roots because of improper definition of the functionscoeffMat[alpha,w])

Please help me out!

Thanks in advance

$\endgroup$
3
  • 2
    $\begingroup$ That sure is a lot of code you're asking people to work through... $\endgroup$
    – ktm
    Commented Feb 6, 2018 at 15:16
  • $\begingroup$ I don't know if that's where the problem comes from, but f[alpha, w] cannot evaluate Im[w] or Re[alpha] (and others) because it did not specify that w and alpha are Reals. Compare your f[alpha, w] with FullSimplify[ComplexExpand@Re[f[alpha, w]], alpha > 0 && w > 0] for example. $\endgroup$
    – anderstood
    Commented Feb 6, 2018 at 15:29
  • 2
    $\begingroup$ Before using a sophisticated function, I recommend starting to plot the curves you want to find the intersections. This helps detect implementation problems and understand the mathematical problem. $\endgroup$
    – anderstood
    Commented Feb 6, 2018 at 15:31

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.