How to get multiple solutions ranked in order？

Question

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:

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?

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. — Rohit Namjoshi, Sep 29 '21 at 01:05
(sol = Solve[{Sin[x] == 0, 0 <= x <= 100}, x][[-1 ;; -10 ;; -1]]) // N — Bob Hanlon, Sep 29 '21 at 03:54

Michael Seifert · Answer 1 · 2021-10-04T17:38:09.707

1

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]}]

(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.

edited Oct 04 '21 at 17:38

answered Sep 29 '21 at 19:19

Michael Seifert

15,208
31
68

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)? – Levin Koo Oct 03 '21 at 02:23
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). – Levin Koo Oct 03 '21 at 02:25
@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. – Michael Seifert Oct 03 '21 at 13:57
@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.) – Michael Seifert Oct 04 '21 at 17:38
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. – Levin Koo Oct 07 '21 at 04:40
@LevinKoo: I'm not sure what you mean. The code I used to create the final plot is the code that's in my post. (Originally there was a minor error in the code, but I corrected it.) – Michael Seifert Oct 07 '21 at 11:09
I was doubt that "NSolveValues" in your code can work, because in my MMA version(12.1.0.0), I cannot find any instruction of "NSolveValues" in documentation center. And more importantly, you said you have made it correct to show the solution points in the picture, I still cannot get the "red points". I'm afraid that we are not running the same code, that's why I asked you for the code. If you indeed tested the code on your computer and got nothing wrong, then perhaps we are using different versions of MMA, which leads to the difference in the running results. – Levin Koo Oct 07 '21 at 12:06
@LevinKoo: Yes, NSolveValues is a new function in MMA 12.3. I think the following will work in 12.1, and return the same results: results = Select[Flatten[Table[neffcl /. NSolve[{J1/(u*J0) == (1 - 2*\[CapitalDelta]n)*(K1/(w*K0)), critpoints[[i + 1]] < neffcl < critpoints[[i]]}, neffcl], {i, 1, Length[critpoints] - 1}]], NumericQ] – Michael Seifert Oct 07 '21 at 12:50
Wonderful solution!!!!!!~~~~~ It works in 12.1. – Levin Koo Oct 07 '21 at 12:55

score 0 · Answer 2 · answered Sep 29 '21 at 05:42

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

How to get multiple solutions ranked in order？

2 Answers2