2
$\begingroup$

I want to get 10 solutions nearest to 100, however the following code returns too small answers, how can I realize my thought?

N[FindInstance[Sin[x] == 0 && x < 100, x, 10]]

{{x -> -1523.67}, {x -> -5642.3}, {x -> -1369.73}, {x -> -2858.85}, \
{x -> -4501.9}, {x -> -5359.56}, {x -> -559.203}, {x -> -3747.92}, {x \
-> -424.115}, {x -> -2192.83}}

EDIT: Firstly, thanks for "Syed","Matthew Heaney" and "Bob Hanlon", thank u so much for ur answers. I have read ur reply carefully,but when it comes to my problem, I still don't know how to tackle it. I am pasting the code I wrote in MMA, and please let me explain what I want to do by posting the question.

ClearAll;
Clear["Global'*"];
$RecursionLimit = Infinity;
nco = 1.4681; ncl = 1.4628; nair = 1; rco = 4.2*10^3; rcl = 
 62.5*10^3; \[CapitalDelta]n = ncl - nair;
wl = 1000;
u = 2*\[Pi]*rcl*((ncl^2 - neffcl^2)^((1/2))/wl);
w = 2*\[Pi]*rcl*((neffcl^2 - nair^2)^((1/2))/wl);
J0 = BesselJ[0, u]; J1 = BesselJ[1, u];
K0 = BesselK[0, w]; K1 = BesselK[1, w];
N[
 FindInstance[
  J1/(u*J0) == (1 - 2*\[CapitalDelta]n)*(K1/(w*K0)) && 
   1.45 < neffcl < 1.463, neffcl, PositiveReals, 50]
 ]
TM
Plot[{J1/(u*J0), (1 - 2*\[CapitalDelta]n)*(K1/(w*K0))}, {neffcl, -2, 
  2}]
Plot[{J1/(u*J0), (1 - 2*\[CapitalDelta]n)*(K1/(w*K0))}, {neffcl, 
  1.453, 1.463}, PlotRange -> {-0.005, 0.005}]
(*TE*)
(*Plot[{J1/(u*J0),(1-2*\[CapitalDelta]n)*(K1/(w*K0))},{neffcl,-2,2},\
WorkingPrecision\[Rule]10]
Plot[{J1/(u*J0),K1/(w*K0)},{neffcl,1.453,1.463},WorkingPrecision\
\[Rule]10,PlotRange\[Rule]{-0.01,0.01}]*)
Clear[neffcl]

And it returns:

{{neffcl -> 1.45092}, {neffcl -> 1.45193}, {neffcl -> 
1.45289}, {neffcl -> 1.4538}, {neffcl -> 1.45467}, {neffcl -> 
   1.45549}, {neffcl -> 1.45628}, {neffcl -> 1.45701}, {neffcl -> 
   1.45835}, {neffcl -> 1.45951}, {neffcl -> 1.4622}, {neffcl -> 
   1.46241}, {neffcl -> 1.46257}, {neffcl -> 1.46269}, {neffcl -> 
   1.46277}}

with pictures:

enter image description here

enter image description here

In the 2nd picture we can see that there are more than 15 solutions for the formula, but it did give 15, actually I want 50(or even 80), I want the solutions from big to small under 1.4628. So how should I make the code work?

$\endgroup$
2
  • 1
    $\begingroup$ Notice that all the values are less than 0 so they satisfy x < 100. Try Reduce[Sin[x] == 0 && 0 < x < 100] you can adjust the condition on x to get the values you need. Or since the values are multiples of Pi compute whatever range you want. $\endgroup$ Commented Sep 29, 2021 at 1:05
  • $\begingroup$ (sol = Solve[{Sin[x] == 0, 0 <= x <= 100}, x][[-1 ;; -10 ;; -1]]) // N $\endgroup$
    – Bob Hanlon
    Commented Sep 29, 2021 at 3:54

2 Answers 2

1
$\begingroup$

For the more complicated problem: The zeros in the desired range all appear to take place between points where the denominator $J_0(u)$ vanishes. Mathematica can calculate the values of neffcl where this occurs, using the BesselJZero function:

nzeros = 20
denomzeros = Flatten[ Table[neffcl /. Solve[{BesselJZero[0, i] == 
   2*\[Pi]*rcl*((ncl^2 - neffcl^2)^((1/2))/wl), neffcl > 0}, neffcl], 
   {i, 1, nzeros + 1}]]

For completeness let's get the zeros of the numerator as well, and combine all these critical points together:

numzeros = Flatten[Table[neffcl /. Solve[{BesselJZero[1, i] == 
   2*\[Pi]*rcl*((ncl^2 - neffcl^2)^((1/2))/wl), neffcl > 0}, neffcl],     
   {i, 1, nzeros + 1}]]
critpoints = Reverse[Sort[Join[numzeros, denomzeros]]]

We can then use NSolve to search for any roots between any of these critical points:

results = Flatten[Table[NSolveValues[{J1/(u*J0) == (1 - 2*\[CapitalDelta]n)*(K1/(w*K0)),
       critpoints[[i + 1]] < neffcl < critpoints[[i]]}, neffcl], 
   {i, 1, Length[critpoints] - 1}]]

(* {1.46277, 1.46269, 1.46257, 1.46241, 1.4622, 1.46195, 1.46165, 
    1.46131, 1.46093, 1.4605, 1.46003, 1.45951, 1.45895, 1.45835, 1.4577, 
    1.45701, 1.45628, 1.45549, 1.45467, 1.4538} *)

We appear to be getting the first nzeros intersections pretty reliably:

Plot[{J1/(u*J0), (1 - 2*\[CapitalDelta]n)*(K1/(w*K0))}, {neffcl, 1.451, 1.463}, PlotRange -> {-0.005, 0.005}, 
     Epilog -> {Red, Point[{#, J1/(u J0) /. neffcl -> #} & /@ results]}]

enter image description here

(The intersections towards the left of the graph are intersections #21, 22, etc. You can increase npoints if you want Mathematica to find them as well.)

This method relies pretty heavily on the form of this function, along with the fact that Mathematica has a built-in function for the zeros of Bessel functions. As such, it might not be readily adaptable to similar problems. I also suspect that I don't really need to look for the points where the numerator vanishes, but I couldn't come up with an airtight argument for leaving them out. Including them doesn't make the results worse, it just makes the calculation take longer.

$\endgroup$
9
  • $\begingroup$ thank you very much for your answer. To get the mathematical solutions, I changed "Solve" to "NSolve" in your code. And another new question is that if I want to get neffcl with wl in the range of 1000 to 2000 every 5 points. What do you sugggest I use(do, for, while)? $\endgroup$
    – Levin Koo
    Commented Oct 3, 2021 at 2:23
  • $\begingroup$ And I didn't get the same picture in your answer, I only get the picture with functions, not with the solutions points(I did't change anything in your code). $\endgroup$
    – Levin Koo
    Commented Oct 3, 2021 at 2:25
  • $\begingroup$ @LevinKoo: Table is often the best choice for doing an iterated calculation where you want the results to be returned, with While being a second choice. You can read about how to do these constructions and their various advantages and disadvantages here and here. As far as the bug in my code, I'll take a look when I'm at a computer with Mathematica and see what I can figure out. $\endgroup$ Commented Oct 3, 2021 at 13:57
  • $\begingroup$ @LevinKoo: I've corrected the error in my code that led to the red intersection points not appearing (the second-to-last code block has changed slightly.) $\endgroup$ Commented Oct 4, 2021 at 17:38
  • $\begingroup$ So may I take a look at the your corrected code as a reference, this problem of solving #neffcl# is just the first step in my researching project, it could help a lot. $\endgroup$
    – Levin Koo
    Commented Oct 7, 2021 at 4:40
0
$\begingroup$

You probably want Solve[]:

Solve[{Sin[x] == 0, 0 <= x <= 100}, x] // Take[#, 10] & // N

That returns the first 10 solutions equal or greater than 0. You could also use Take[#, -10]&, which would return the last 10 solutions less or equal to 100.

Reduce[] would also work:

Reduce[Sin[x] == 0 && 0 <= x <= 100] // {ToRules[#]} & // Take[#, 10] & // N 
$\endgroup$

Your Answer

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

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