A numerical Example

Rigorous estimates of a fixed point in a ring of four Lorenz systems

The precision of the computation is set to sufficienly many digits for our purposes.

$MaxExtraPrecision  =  10000

$MinPrecision  =  30

In the first section of the program we calculate a very accurate approximation to the fixed state whose stability we will later establish.   We begin by assigning values to the parameters that appear in the Lorenz equations.

ss  =  10;  bbb  =  8/3;  rrr  =  27; ddd = 15/10;

The following function defines the fixed points in a chain of Lorenz equations.

x =. ; y =. ; z =. ; s  =. ; b =. ; rr  =. ; d =.

f[y_, x_,  z_] =  
      s * (x  -  (b*rr*x/(b + x^2)))  - 
        d * ( y  -  2*x  +  z)

This function will be used for the approximation of the  roots.  The variables aa, bb, cc, and dd will be used
for the approximate values of the roots.

g[x_] =  ss * (x  -  (bbb*rrr*x/(bbb + x^2)));

vars  =  {dd,  aa,  bb,  cc,  dd,  aa};

Now we define the equations to find the roots to arbitrary precision.  The output of the numerical simulations in XPP is used as an initial guess and is stored in the variables y1, y2, y3 and y4.  The table eqns contains the four equations which a fixed state of the ring needs to satisfy.

y1  =  -6.4114408;  y2  =  7.3696656; y3  = 8.1984129;   
    y4  = 7.3696656;

eqns = 
      Table [ g[ vars[[ll + 1]] ] -  
            ddd*(vars[[ll]] - 2*vars[[ll + 1]] +  
                  vars[[ll + 2]]) == 0,  {ll,  1,  4}];

eqns

Next we use these initial guesses to find the roots numerically with y1, y2, y3 and y4 as initial guesses.  The variables aa, bb, cc, and dd are then set equal to these values.

FindRoot[eqns,  {aa,  y1 - .1,  y1 + .1}, 
       {bb, y2 - .1,  y2 + .1},  {cc,  y3 - .1,  y3 + .1}, 
       {dd,  y4 - .1,  y4 + .1},  WorkingPrecision  ->  200,  
      AccuracyGoal  ->  40]

approx =  {aa,  bb,  cc,  dd} /.  %;

We will next use Kantorovich's Convergence Theorem (Theorem 6.2) and interval arithmetic to rigorously prove that the equations defined in eqns have roots in a small neighborhood of the values that were found numerically.   We first define all quantities as intervals so that interval arithmetic can be used in the subsequent computations.

F[x_, y_, z_, w_]  = 
       {f[w, x,  y],  f[x,  y,  z],  f[y, z,  w],  f[z, w, x]};

s  =  Interval[10];  b  =  Interval[8/3];   
    rr  =  Interval[27];  d =  Interval[15/10];

\(x1\  = \ Interval[approx[\([1]\)]]; \ x2\  = Interval[approx[\([2]\)]]; 
    
x3\  = \ Interval[approx[\([3]\)]]; \ 
    x4\  = \ Interval[approx[\([4]\)]]; \)

Feval =  F[x1, x2, x3, x4];

Next we define M, the Jacobian of the function F.  The inverse of this Jacobian, which is here called G, is needed for the verification of the hypothesis of Kantorovich's Theorem.

f1  =  D[f[x, y, z], x];

f2[y_]  =  D[f[x, y, z], y];

f3  =  D[f[x, y, z], z];

\(\(M[x_, y_, z_, w_]\  = 

      	{{f2[x], \ f3, \ 0, \ f1}, {f1, \ f2[y], \ f3, \ 0}, {0, f1, \ f2[z], 
          f3}, 
		{f3, \ 0, \ f1, \ f2[w]}}; \)\)

Meval  = M[x1,  x2, x3, x4];

G  =  Inverse[M[x1,  x2, x3, x4]];

The constants A, B and CC are defined as in Kantorovich's Theorem.  The quantity 1/(A*CC) * (1 - Sqrt[1 - 2 A B CC) gives the maximum size of the box around each root.  The extended precision used here will be essential in the second part of the calculations.

r[i_]  :=  Sum[ Abs[G[[i, k]]],  {k, 1, 4}];

q[i_]  :=  
      Sum[ Abs[G[[i, k]] * Feval[[k]]],  {k,  1,  4}]

A  =  Interval[Max[r[1], r[2],  r[3],  r[4]]];

B  =  Interval[Max[ q[1], q[2],  q[3],  q[4]]];

1/(2*A*B )

CC needs to be less than 1/(2AB), so we choose CC=10.

CC =  Interval[10];

1/(A*CC) * (1  -  Sqrt[1  -  2*A * B * CC])

The last computation shows that, if we can check the other estimates of Kantorovich's Theorem, then 5 x 10^(-29) can be used as the size of the box in which the roots are guaranteed to lie.  Since the second derivatives of f_i with respect to x_i are the only non-zero second derivatives,  it is sufficient to check that each of them is less than CC = 10 in absolute value at all points in the rectangular region R around each root.

We first define the intervals xx1, xx2, xx3, and xx4 of width 10^(-29) in which the roots will be proved to lie.

box  =  Interval[{-5*10^(-29),  5*10^(-29)}];

\(xx1\  = \ x1 + box; \ xx2\  = \ x2 + box; 
xx3\  = \ x3 + box; \ 
    xx4\  = \ x4 + box; \)

Next we check the last condition in Kantorovich's Theorem.  There are only four nonzero terms that need to be checked.

D2f[y_]  =  D[f[x, y, z],  {y, 2}];

D2f[xx1]

D2f[xx2]

D2f[xx3]

D2f[xx4]

Since each of these four values is less than CC = 10 in absolute value, the hypothesis of Kantorovich's theorem are satisfied, and a root of F is proved to lie in the rectangular region (xx1, xx2, xx3, xx4).

Now we use the above approximations to find the characteristic polynomial

First we define the matrix D(t) of equation (33).

g[x_] =  
      -Interval[10] 
        (x - Interval[27]*
              (x/((Interval[3/8])*x^2 + Interval[1])));

s  =  10;  rr  = 27;  b = 8/3; d = 15/10;

z =  rr*x^2/(b + x^2);

y  =  rr*x/(1  +  x^2/b);

M[x_] = 
       {{-s,  s,  0},  {rr - z,  -1,  -x}, 
         {y,  x,  -b}};

MatrixForm[M[x]]

The matrices that appear on the diagonal of D(t) are exactly of the form M[x].   Next we use this matrix valued function to define the entire matrix D(t) for the fixed state (xx1, xx2, xx3, xx4).   Since xx1, xx2, xx3 and xx4 are intervals the matrix D(t), which is here denoted MMexp, will be a matrix of intervals.

dat2  =  {a1,  a2,  a3, a4};

Mdat2 = 
      Table [If[ IntegerPart[(i - 1)/3] == IntegerPart[(j - 1)/3], 
           M[dat2[[IntegerPart[(i - 1)/3] + 1]]][
            [Mod[i - 1, 3] + 1,  Mod[j - 1, 3] + 1]],  0], 
         {i, 1,  12},  {j, 1,  12}];

Lapexp =  
      Table[Switch[i - j, 0,  If[Mod[i - 1, 3] == 0,  -2, 0],   3,  
          If[Mod[i - 1,  3] == 0,  Exp[-I * t],  0],  -3, 
          If[Mod[i - 1,  3] == 0,  Exp[ I*t],  0],  _,  0], 
         {i,  12},  {j,  12}];

Lapexp[[1, 10]] = Exp[-I*t];  
    Lapexp[[10, 1]]  =  Exp[I*t];

MMexp =  Mdat2 +  d* Lapexp;

MatrixForm[MMexp]

The matrix MMexp above is exactly the matrix D(t). We now define a1, a2, a3, and a4 as the roots that were calculated in the previous section.

{a1,  a2,  a3,  a4}  =  {xx1,  xx2,  xx3,  xx4};

Next we calculate its characteristic polynomial poly[x,t] of the matrix MMexp. Since this is a 12 x 12 matrix, and the calculations involve interval arithmetic a direct evaluation is inefficient.  The sparseness of the matrix and cofactor expansion are used so that the calculations of poly[x,t] involve only 10 x 10 matrices.

L  =  MMexp  -  x*IdentityMatrix[12];

\(\(poly[x_, t_]\  = 
      Collect[\ Det[L[\([{1, 2, 3}, {1, 2, 3}]\)]]*
            Det[L[\([Range[4, 12], \ Range[4, 12]]\)]]\  - \ 
          d*\ Exp[I*t]\ *
			
            \((L[\([2, 1]\)]*
                  Det[L[\([Range[3, 12], Join\ [{2, 3}, \ Range[5, 12]]]\)]]\ 
                 - \ L[\([2, 2]\)]*
                  Det[L[\([Range[3, 12], Join\ [{1, 3}, \ Range[5, 12]]]\)]]
                     + 
					
                L[\([2, 3]\)]*\ 
                  Det[L[\([Range[3, 12], Join\ [{1, 2}, \ Range[5, 12]]]\)]])
              \) - \ 
		
          d*Exp[\(-I\)*t]*
					
            \((L[\([2, 1]\)]*
                  Det[L[\([Range[3, 12], Join\ [Range[2, 9], \ {11, 12}]]\)]]
                    \  - \ L[\([2, 2]\)]*
                  Det[L[\([Range[3, 12], Join\ [{1}, Range[3, 9], \ {11, 12}]]
                        \)]] + 
					
                L[\([2, 3]\)]*\ 
                  Det[L[\([Range[3, 12], 
                        Join\ [{1, 2}, \ Range[4, 9], {11, 12}]]\)]])\), x]; 
    \)\)

We find the approximate eigenvalues of the matrix at t = Pi/4 and use the theorem for the proof of convergence of Newton's Method (Theorem 6.1) again to show that  these are close to the real eigenvalues.    The matrix MMe is defined in exactly the same way as MMexp above.  The only difference is that the matrix is evaluated at the approximate fixed state approx[[i]] defined in the previous section, rather than at the intervals which were obtained using Kantorovich's method.  This portion of the compuation therefore involves only floating point numbers.

dat  = 
       {approx[[1]], approx[[2]],  approx[[3]], 
        approx[[4]]};

Mdat = 
      Table [If[ IntegerPart[(i - 1)/3] == IntegerPart[(j - 1)/3], 
           M[dat[[IntegerPart[(i - 1)/3] + 1]]][
            [Mod[i - 1, 3] + 1,  Mod[j - 1, 3] + 1]],  0], 
         {i, 1,  12},  {j, 1,  12}];

MMe =  Mdat +  d* Lapexp;

p[x_, t_] = Collect[Det[MMe - IdentityMatrix[12]*x], x];

Here we set the time at which we are taking the evaluation, and use a standard Mathematica function to find the approximate root of the polynomial poly[x, Pi/4].

t0  =  Pi/4;

rootsrule  =  NSolve[p[x, t0]  ==  0,  x, 16]

Rigorous proof that these roots are in the left half of the complex plane.

These are the approximate eigenvalues at t= Pi/4.  Next we use theorem 6.1 to show rigorously that there is a rectangle around each of these approximate roots which contains an acutal root of poly[x,Pi/4].  If we can show that these intervalslie in the left half of the complex plane, and that the roots do not cross the imaginary axis as t is varied, we are done.

roots  =  x  /.  rootsrule;

\(pp[x_, t_]\  = \ D[p[x, t], \ x]; 

    polyp[x_, t_]\  = \ D[poly[x, t], \ x]; 

    polypp[x_, t_]\  = \ \ D[polyp[x, t], \ x]; 

    polyppp[x_, \ t_]\  = \ D[polypp[x, t], \ x]; \)

Next we define the function hh which is equivalent to the function h0 in theorem  6.1.  We need this function to verify that the roots that we obtained are actual roots.  To define this function the absolute value of the polynomial p[x,t] and
its derivative are needed.  The second derivative is also needed to verify the hypothesis of the theorem.   We  therefore first calculate these quantities using interval arithemtic.

 Since Mathematica does not support complex interval arithmetic, some  manipulation of the equations was necessary to put them in a form appropriate for our purposes.  In particular cf, cfp, cfpp denote the coefficients of the characteristic polynomial and its first two derivatives respectively.  Note that these coefficients are intervals.

\(cff = CoefficientList[poly[x, 0], x]; 

    cfb\  = \ Coefficient[ExpToTrig[CoefficientList[poly[x, t], x]], \ 
        Cos[4*t]]; 
cfa\  = \ cff\  - \ cfb; 

    cf\  = \ cff\  - \ cfb\  + cfb*\ Cos[4*t0]; 

    cfpf = \ CoefficientList[polyp[x, 0], \ x]; 

    cfpb\  = \ 
      Coefficient[ExpToTrig[CoefficientList[polyp[x, t], x]], \ Cos[4*t]]; 

    cfpa\  = \ cfpf\  - cfpb; 

    cfp\  = \ cfpf\  - \ cfpb\  + \ cfpb*\ Cos[4*t0]; 

    cfppf = \ CoefficientList[polypp[x, 0], \ x]; 

    cfppb\  = \ 
      Coefficient[ExpToTrig[CoefficientList[polypp[x, t], x]], \ Cos[4*t]]; 

    cfpp\  = \ cfppf\  - \ cfppb\  + \ cfppb*\ Cos[4*t0]; \)

Next we define the vectors of monomials.  The real and imaginary part of these vectors will be used to find |poly(x,Pi/4)|,  |poly'(x,Pi/4)| and |poly''(x,Pi/4)| evaluated at each root of the characteristic polynomial.

\(powers[x_]\  = 
      \ {1, x, \ x^2, \ x^3, \ x^4, \ x^5, \ x^6, \ x^7, \ x^8, \ x^9, \ 
        x^10, \ x^11, \ x^12}; 

    powersp[x_]\  = 
      \ {1, x, \ x^2, \ x^3, \ x^4, \ x^5, \ x^6, \ x^7, \ x^8, \ x^9, \ 
        x^10, \ x^11}; 

    powerspp[x_]\  = 
      \ {1, x, \ x^2, \ x^3, \ x^4, \ x^5, \ x^6, \ x^7, \ x^8, \ x^9, \ 
        x^10}; 
rl[i_] := Re[powers[roots[\([i]\)]]]; 

    rlp[i_] := \ Re[powersp[roots[\([i]\)]]]; 

    rlpp[i_]\  := \ Re[powerspp[roots[\([i]\)]]]; 

    img[i_]\  := \ Im[powers[roots[\([i]\)]]]; 

    imgp[i_]\  := \ Im[powersp[roots[\([i]\)]]]; 

    imgpp[i_]\  := \ Im[powerspp[roots[\([i]\)]]]; \)

Taking the the dot product of the real part of the vector powers evaluated at a root and doting it with cf, the vector of coefficients of the polynomial poly(x,Pi/4), gives the real part of the polynomial poly(x, Pi/4) evalueated at that root.  Taking the square root of the squares of the imaginay and real parts gives exactly |poly(x, Pi/4)|.  The absolute values of the polynomial and its first two derivatives evalueated at the i-th root of the characteristic polynomial are stored in ABS(i), ABSP(i), and ABSPP(i) respectively.

ABS[i_]  :=  Sqrt[(rl[i].cf)^2  +  (img[i].cf)^2]ABSP[i_]  :=  Sqrt[(rlp[i].cfp)^2  +  (imgp[i].cfp)^2]ABSPP[i_]  :=  
      Sqrt[(rlpp[i].cfpp)^2  +  (imgpp[i].cfpp)^2]

It is now easy to define the function h_0 of theorem 6.1 as the ratio of the absolute value of poly and the absolute value of its first derivative evaluated at each root.   We next define rts(i) as the square around the root in which the root will be proven to lie. These squares contain the discs K_0 defined of radius hh(i).  If the last condition in theorem 6.1 can be checked than these roots must lie in the left half of the complex plane.

hh[i_] :=  ABS[i]/ABSP[i]rts[i_]  :=  
      Re[roots[[i]]] + Interval[{-Max[hh[i]],  Max[hh[i]]}] +  
        I*(Im[roots[[i]]] + Interval[{-Max[hh[i]],  Max[hh[i]]}])

Table[rts[n],  {n, 1, 12}]

To check the last condition of the theorem we need the supremum |poly''(x, Pi/4)| evaluated on each of the squares 
rts(i).  This value can be estimated by using interval arithmetic to evaluate  |poly''(x, Pi/4)| at rts(i).  This value is stored in ABSPP2(i)

\(rllll = \ \ 
      Table[Re[Simplify[Expand[powerspp[rts[i]]]]], \ {i, \ 1, \ 12}]; 

    imlll = \ Table[Im[Simplify[Expand[powerspp[rts[i]]]]], 
        \ {i, \ 1, \ 12}]; \)

ABSPP2[i_]  :=  
      Sqrt[(rllll[[i]].cfpp)^2  +  (imlll[[i]].cfpp)^2]

To verify the conditions of the theorem we need to check that 2*hh*ABSPP2/ABSP <1.  This is done below.

chk[i_]  :=  (ABSPP2[i]*hh[i]*2) /ABSP[i]

Table[chk[n],  {n, 1, 12}]

Checking that the roots do not cross the imaginary axis as t is varied

In this part we will be checking that the real part and the imaginary part of the polynomial p_d(x, t) are not zero simulatenoulsy for any x on the imaginary axis and t in the interval [0, Pi/2].

By Gresgorin estimates we can check that the eigenvalues must have imaginary parts between -17 and 17.  Thus we only need to check that they do not cross the imaginary axis between these points.   Since all roots are either real or come in conjugate pairs, it is sufficient to check that the roots do not lie in [-17,0].

Once the polynomial p_D is split into its real and imaginary part, it remains to split the interval [-17, 0] and [0, Pi/2] into sufficiently many intervals on which neither the real part poly1 nor, the imaginary part poly2 of the polynomial p_D change sign.

int =  0;  powerseven =. ;  powersodd =.  ;

\(powerseven[x_] = {1, x^2, \ x^4, \ x^6, \ x^8, \ x^10, \ x^12}; 

    powersodd[x_]\  = \ {x, \ x^3, \ x^5, \ x^7, \ x^9, \ x^11}; \)

We now set up loops that check that no crossings occur.  An interval in which both the imaginary and real part of the characteristic polynomial contain 0 is printed.  Further refinement is needed for such intervals. 

The first loop subdivides the interval [-17, -11] into subintervals of size 0.001, and the time interaval [0, Pi/2] into subintervals of size 0.1.  All these intervals are then checked for a potential crossing.

int = 0;

\(While[\((int\  = \ int + \ 0.1)\)\  < \ Pi/2, 

      tt = Interval[{int\  - 0.1, \ int}]; 

      cf2 = \ cff\  - \ cfb\  + cfb*\ Cos[4.0*tt]; 

      cfeven\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 1)\)/2)\), 
          \ {i, \ 1, \ 13, \ 2}]; 

      cfodd\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 2)\)/2)\), 
          \ {i, \ 2, \ 12, \ 2}]; 
poly1 =. ; poly2 =. ; 

      poly1[x_]\  := \ cfeven.powerseven[x]; 

      poly2[x_] := \ cfodd.powersodd[x]; 
f\  = \(-17\); 

      While[\((f\  = \ f + 0.001)\)\  < \ \(-11\), \ 
	
        If[Sign[Min[poly2[Interval[{f, \ f + 0.001}]]]] =!= 
              Sign[Max[poly2[Interval[{f, \ f + 0.001}]]]]\  && 
            Sign[Min[poly1[Interval[{f, \ f + 0.001}]]]] =!= 
              Sign[Max[poly1[Interval[{f, \ f + 0.001}]]]], \ 

          								Print[Interval[{f, f + 0.001}]]]]]\)

int  =  0;

\(While[\((int\  = \ int + \ 0.1)\)\  < \ Pi/2, 

      tt = Interval[{int\  - 0.1, \ int}]; 

      cf2 = \ cff\  - \ cfb\  + cfb*\ Cos[4.0*tt]; 

      cfeven\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 1)\)/2)\), 
          \ {i, \ 1, \ 13, \ 2}]; 

      cfodd\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 2)\)/2)\), 
          \ {i, \ 2, \ 12, \ 2}]; 
poly1 =. ; poly2 =. ; 

      poly1[x_]\  := \ cfeven.powerseven[x]; 

      poly2[x_] := \ cfodd.powersodd[x]; 
f\  = \(-7\); 

      While[\((f\  = \ f + 0.001)\)\  < \ \(-0\), \ 
	
        If[Sign[Min[poly2[Interval[{f, \ f + 0.001}]]]] =!= 

              \ \ \ \ \ \ \ \ \ \ 
              Sign[Max[poly2[Interval[{f, \ f + 0.001}]]]]\  && 

            \ \ \ \ \ \ \ \ 
            Sign[Min[poly1[Interval[{f, \ f + 0.001}]]]] =!= 

              \ \ \ \ \ \ \ \ \ \ 
              Sign[Max[poly1[Interval[{f, \ f + 0.001}]]]], \ 

          								Print[Interval[{f, f + 0.001}]]]]]\)

int  =  0;

\(While[\((int\  = \ int + \ 0.05)\)\  < \ Pi/2 + 0.05, 

      tt = Interval[{int\  - 0.05, \ int}]; 

      cf2 = \ cff\  - \ cfb\  + cfb*\ Cos[4.0*tt]; 

      cfeven\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 1)\)/2)\), 
          \ {i, \ 1, \ 13, \ 2}]; 

      cfodd\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 2)\)/2)\), 
          \ {i, \ 2, \ 12, \ 2}]; 
poly1 =. ; poly2 =. ; 

      poly1[x_]\  := \ cfeven.powerseven[x]; 

      poly2[x_] := \ cfodd.powersodd[x]; 
f\  = \(-8.3\); 

      While[\((f\  = \ f + 0.0001)\)\  < \ \(-7\), \ 
	
        If[Sign[Min[poly2[Interval[{f, \ f + 0.0001}]]]] =!= 

              \ \ \ \ \ \ \ \ \ \ 
              Sign[Max[poly2[Interval[{f, \ f + 0.0001}]]]]\  && 

            \ \ \ \ \ \ \ \ 
            Sign[Min[poly1[Interval[{f, \ f + 0.0001}]]]] =!= 

              \ \ \ \ \ \ \ \ \ \ 
              Sign[Max[poly1[Interval[{f, \ f + 0.0001}]]]], \ 

          								Print[Interval[{f, f + 0.0001}]]]]]\)

These three computations show that there are no roots in the intervals [-17, -11] and [-8.3,0].  These are the quickest compuations since all the roots are relatively far from these intervals, and thus a coarse subdivision of the intervals is sufficient.  Next we check the interval [-11, 8.3].  We start with [-11, -10.2].

int  =  0;

\(While[\((int\  = \ int + \ 0.01)\)\  < \ Pi/2 + 0.01, 

      tt = Interval[{int\  - 0.01, \ int}]; 

      cf2 = \ cff\  - \ cfb\  + cfb*\ Cos[4.0*tt]; 

      cfeven\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 1)\)/2)\), 
          \ {i, \ 1, \ 13, \ 2}]; 

      cfodd\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 2)\)/2)\), 
          \ {i, \ 2, \ 12, \ 2}]; 
poly1 =. ; poly2 =. ; 

      poly1[x_]\  := \ cfeven.powerseven[x]; 

      poly2[x_] := \ cfodd.powersodd[x]; 
f\  = \(-11\); 

      While[\((f\  = \ f + 0.000001)\)\  < \ \(-9.28\), \ 
	
        If[Sign[Min[poly2[Interval[{f, \ f + 0.000001}]]]] =!= 
              Sign[Max[poly2[Interval[{f, \ f + 0.000001}]]]]\  && 
            Sign[Min[poly1[Interval[{f, \ f + 0.000001}]]]] =!= 
              Sign[Max[poly1[Interval[{f, \ f + 0.000001}]]]], \ 

          								Print[Interval[{f, f + 0.000001}]]]]]\)

There is another rough spot in [-9.28, -9.2], and an even finer subdivision is needed.

int  =  0;

\(While[\((int\  = \ int + \ 0.01)\)\  < \ Pi/2 + \ 0.01, 

      tt = Interval[{int\  - 0.01, \ int}]; 

      cf2 = \ cff\  - \ cfb\  + cfb*\ Cos[4.0*tt]; 

      cfeven\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 1)\)/2)\), 
          \ {i, \ 1, \ 13, \ 2}]; 

      cfodd\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 2)\)/2)\), 
          \ {i, \ 2, \ 12, \ 2}]; 
poly1 =. ; poly2 =. ; 

      poly1[x_]\  := \ cfeven.powerseven[x]; 

      poly2[x_] := \ cfodd.powersodd[x]; 
f\  = \(-9.28\); 

      While[\((f\  = \ f + 0.0000001)\)\  < \ \(-9.2\), \ 
	
        If[Sign[Min[poly2[Interval[{f, \ f + 0.0000001}]]]] =!= 
              Sign[Max[poly2[Interval[{f, \ f + 0.0000001}]]]]\  && 
            Sign[Min[poly1[Interval[{f, \ f + 0.0000001}]]]] =!= 
              Sign[Max[poly1[Interval[{f, \ f + 0.0000001}]]]], \ 

          						Print[int]; 		Print[Interval[{f, f + 0.0000001}]]; \ 
          Break[]]]]\)

We check the interval [-9.2,-8.3] next.  This completes the calculations.

int = 0;

\(\(\(While[\((int\  = \ int + \ 0.01)\)\  < \ Pi/2 + \ 0.01, 

      Print[int]; 
tt = Interval[{int\  - 0.01, \ int}]; 

      cf2 = \ cff\  - \ cfb\  + cfb*\ Cos[4.0*tt]; 

      cfeven\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 1)\)/2)\), 
          \ {i, \ 1, \ 13, \ 2}]; 

      cfodd\  = \ 
        Table[cf2[\([i]\)]*\((\(-1\))\)^\((\((i - 2)\)/2)\), 
          \ {i, \ 2, \ 12, \ 2}]; 
poly1 =. ; poly2 =. ; 

      poly1[x_]\  := \ cfeven.powerseven[x]; 

      poly2[x_] := \ cfodd.powersodd[x]; 
f\  = \(-9.2\); 

      While[\((f\  = \ f + 0.000001)\)\  < \ \(-8.3\), \ 
	
        If[Sign[Min[poly2[Interval[{f, \ f + 0.000001}]]]] =!= 
              Sign[Max[poly2[Interval[{f, \ f + 0.000001}]]]]\  && 
            Sign[Min[poly1[Interval[{f, \ f + 0.000001}]]]] =!= 
              Sign[Max[poly1[Interval[{f, \ f + 0.000001}]]]], \ 

          						Print[int]; 		Print[Interval[{f, f + 0.000001}]]; \ 
          Break[]]]]; \)
\)\)