Defining a function by pieces using list of interpolated functions in order to use FindRoot

I have two lists with the interpolated functions

list1 = {InterpolatingFunction[{{a1, b1}},<>], InterpolatingFunction[{{a2, b2}},<>],
InterpolatingFunction[{{a3, b3}},<>], InterpolatingFunction[{{a4, b4}},<>]}

which I will think as $\mbox{list1} = \{f_1(x),f_2(x),f_3(x),f_4(x)\}$, and

list2 = {InterpolatingFunction[{{c1, d1}},<>], InterpolatingFunction[{{c2, d2}},<>],
InterpolatingFunction[{{c3, d3}},<>], InterpolatingFunction[{{c4, d4}},<>]}

which I will think as $\mbox{list2} = \{g_1(x),g_2(x),g_3(x),g_4(x)\}$.

What I need is to define $$f(x) = \begin{cases} f_1(x) & a_1 < x < b_1 \\ f_2(x) & a_2 < x < b_2 \\ f_3(x) & a_3 < x < b_3 \\ f_4(x) & a_4 < x < b_4 \end{cases} \quad \mbox{and} \quad g(x) = \begin{cases} g_1(x) & c_1 < x < d_1 \\ g_2(x) & c_2 < x < d_2 \\ g_3(x) & c_3 < x < d_3 \\ g_4(x) & c_4 < x < d_4 \end{cases}$$ in order to find a root of the equation $$f(x) - g(x) = 0$$

using the code

FindRoot[{f[x] - g[x] == 0},{x,x0}]

where the intervals $(a_i,b_i)$, $(c_i,d_i)$ are are well ordered (i.e. $a_1 < b_1 < a_2 < b_2 < ... < b_4$), and $x_0 \in [\min(a_1,c_1),\max(b_4,d_4)]$.

Here is an example:

list1 = Interpolation /@ Table[{2 i + k, Tan[k]}, {i, 1, 3, 2}, {k, -(\[Pi]/2) + 0.1,
\[Pi]/2 - 0.1, 0.1}];

list2 = Interpolation /@ {Table[{i, i (i + 1/2) (i - 4)}, {i, -2, 5, 0.1}],
Table[{i, 5 (i - 8)}, {i, 6, 9, 0.1}]};

x0 = RandomReal[{-2, \[Pi]/2 - 0.1 + 8}];

In this case, $\mbox{list1} = \{f_1(x),f_2(x),f_3(x)\}$ and $\mbox{list2} = \{g_1(x),g_2(x)\}$.

I don't mind if no solution can be found for some $x_0$; what I don't want is to obtain spurious solutions due to extrapolation, or other gimmicks MMA might be using to "glue" the interpolated functions. In this particular example, the root $x \sim 9.43$ would be spurious, since neither $f$ nor $g$ are defined there.

$\hskip1.5in$ Thanks for your time.

EDIT

Using @b.gatessucks suggestion, if I define

f[x_] := Piecewise[{{list1[][x], -(\[Pi]/2) + 0.1 < x < \[Pi]/2 - 0.1},
{list1[][x], -(\[Pi]/2) + 0.1 + 4 < x < \[Pi]/2 - 0.1 + 4},
{list1[][x], -(\[Pi]/2) + 0.1 + 8 < x < \[Pi]/2 - 0.1 + 8}}];

g[x_] := Piecewise[{{list2[][x], -2 < x < 5}, {list2[][x], 6 < x < 9}}];

then

sols = Union[x /. FindRoot[f[x] == g[x], {x, #}] & /@
Table[i, {i, -2, \[Pi]/2 - 0.1 + 8, .1}], SameTest -> (Abs[#1 - #2] <= 10^-6 &)]

returns some spurious solution:

$\hskip1cm$ Is there a way to automatically drop such solutions (for example generating the grid only where both f and g are defined)?

• Can't you use Piecewise ? – b.gates.you.know.what Mar 6 '13 at 20:38
• @b.gatessucks It's a little more convoluted than that – Dr. belisarius Mar 7 '13 at 4:38

This glues together a list of InterpolatingFunction into a Piecewise that is Indeterminate outside the domains, the reason for this is that FindRoot aborts when it encounters that as a function value.

pieceTogether[list_] := Function[\[FormalT],
Evaluate@Piecewise[
Map[{#@\[FormalT], #["Domain"][[1, 1]] <= \[FormalT] <= #["Domain"][[1, 2]]} &,list],
Indeterminate]];

It uses an undocumented(?) feature to extract the domain of the InterpolatingFunction, you could do it in other ways but I find this the most convenient:

(First@list1)["Domain"]
(* {{0.529204, 3.4292}} *)

It is used like:

(* Evaluate f[t] to see what it did *)
f = pieceTogether[list1];
g = pieceTogether[list2];

p = Plot[{f[t], g[t]}, {t, -2.5, 10}];
Manipulate[
(* If FindRoot gives some error suppress it and return None *)
root = Quiet@Check[x /. FindRoot[f[x] == g[x], {x, x0}], None];
(* Red point at the root or black on axis *)
{color, pt} = If[root =!= None, {Red, {root, f[root]}}, {Black, {x0, 0}}];
Show[p, Epilog -> {PointSize[Large], color, Point[pt]}]
,{{x0, 1}, -2.5, 12}] • This is fantastic! Thank you very much! – Pragabhava Mar 6 '13 at 21:24

The following tries to find one root in each subinterval where both functions are defined:

list1 = Interpolation /@ Table[{2 i + k, Tan[k]}, {i, 1, 3, 2},
{k, -(\[Pi]/2) + 0.1, \[Pi]/2 - 0.1, 0.1}];

list2 = Interpolation /@ {Table[{i, i (i + 1/2) (i - 4)}, {i, -2, 5, 0.1}],
Table[{i, 5 (i - 8)}, {i, 6, 9, 0.1}]};

Needs["DifferentialEquationsInterpolatingFunctionAnatomy"];
ClearAll[u];
f1 = Piecewise[{#[u], Less @@ Riffle[InterpolatingFunctionDomain[#][], u]}&/@ list1, 100];
g1 = Piecewise[{#[u], Less @@ Riffle[InterpolatingFunctionDomain[#][], u]}&/@ list2, 100];
i = (IntervalUnion @@ (Interval@ InterpolatingFunctionDomain[#][] & /@ #)) &;
i1 = List @@ IntervalIntersection[i@list1, i@list2];
If[Chop@(f1 - g1 /. u -> x /. #) == 0., #, {}] & /@
FindRoot[Evaluate[(f1 - g1 == 0) /. u -> x], #] & /@ ({x, Mean@#, Sequence @@ #} & /@ i1)

(*
{{x -> 0.747098}, {{}}, {{}}}
*)
• This is great too! Now I need to modify it to find all roots in the subintervals. Thanks a lot! – Pragabhava Mar 7 '13 at 1:48
• Is there an easy way to adapt it to problems of the form FindRoot[{h1[x,y] + f1[x]==0, h2[x,y] + g1[y] == 0},{{x,x0},{y,y0}}] Where h1 and h2 are continuous functions and f1, g1 are the Piecewise defined functions? I'm having lots of troubles trying. – Pragabhava Mar 7 '13 at 4:21
• @Pragabhava Not really sure ... perhaps another good question there – Dr. belisarius Mar 7 '13 at 4:37