Location of singularities of diagonal quadratic and differential approximants

Mathematica program

(* Location of singularities of diagonal quadratic and differential approximants *)

(* Options *)
mindlist = 10; (* number of approximants *)
ncrop = 20; (* disregard coefficients with N>ncrop *)
ndrop = 0; (* how many coeff. to drop from beginning of series *)
xyrange = 2.5/asave[name]; (* plot range *)

sect = "sings3";
entity = "figure";
cf = If[nm > ncrop, Take[func, ncrop], func];
cf = Drop[cf, ndrop];
nmax = Length[cf];

(* Create table of indexes of approximants *)
indlist = {};
Do[Do[
      ind = {n1, n2, n3};
      nuse = Plus@@ind + 2;
      prior = 1.1^nuse;
      If[n1 < 0 || n2 < 0 || n3 < 1 || nuse > nmax,
        Continue[]];
      If[Abs[n1 - n2] > 1 || Abs[n2 - n3] > 1 || Abs[n3 - n1] > 1,
        Continue[]];
      If[!(n1<=n2<=n3<=n1+1), Continue[]];
(*
      If[n1 == n2 == n3, prior = 30 prior];
      prior = (*2^(n2 - n1) 3^(n3 - n2)*) prior;
*)
      indlist = Append[indlist, {ind, prior, nuse}];
      , {n2, n1, n1 + 1}, {n3, n1, n1 + 1}], {n1, 0, nm}];
indlist = Sort[indlist, #1[[2]] > #2[[2]] &];
mi = Length[indlist];
If[mindlist < mi, indlist = Take[indlist, mindlist]; mind = mindlist, mind = mi];
indlist = Sort[indlist, #1[[3]] < #2[[3]] &];
tind = Transpose[indlist];
pind = {ToString /@ tind[[1]], tind[[3]]};
If[iprint,Print["Indexes: ", pind // TableForm]];
boxed1[symb_] := 
    "\!\(\* StyleBox[ FrameBox[StyleBox[\"" <> symb <> 
      "\", FontSize->16, FontWeight->\"Bold\", FontColor->GrayLevel[0]],
BoxMargins->{{0.2, 0.2}, {0.6, 0.6}}], FontSize->12,
 FontWeight->\"Plain\", FontColor->GrayLevel[1],
 Background->GrayLevel[1], FontVariations->{\"CompatibilityType\"->0}]\)";
boxed2[symb_] := 
    "\!\(\* StyleBox[ FrameBox[StyleBox[\"" <> symb <> 
      "\", FontSize->16, FontWeight->\"Bold\", FontColor->RGBColor[0,0,0]],
BoxMargins->{{0.2, 0.2}, {0.6, 0.6}}], FontSize->12,
 FontWeight->\"Plain\", FontColor->GrayLevel[0.7],
 Background->GrayLevel[1], FontVariations->{\"CompatibilityType\"->0}]\)";
If[mindlist > 1,
mslist = Length[slist0];
If[mslist==0, plts = {}];
If[mslist==1,
{singdom} = slist0;
slist = Union[slist0, Conjugate[slist0]];
slist = {{Re[#], Im[#]}} & /@ slist;
scale = 2.2;
If[newfigure == True, plts = MultipleListPlot[slist,
            SymbolShape -> shape[1],
            SymbolStyle -> {{Thickness[0.004 scale], RGBColor[1,0,0]}},
            PlotRange -> xyrange{{-1, 1}, {-1, 1}},
            AspectRatio -> 1,
            Frame -> True,
            ImageSize -> 400,
            DisplayFunction -> Identity]];
   ];
If[mslist==2,
{singdom, singsub} = slist0;
slist1 = Union[{singdom}, {Conjugate[singdom]}];
slist1 = {{Re[#], Im[#]}} & /@ slist1;
slist2 = Union[{singsub}, {Conjugate[singsub]}];
slist2 = {{Re[#], Im[#]}} & /@ slist2;
scale = 2.2;
If[newfigure == True, plts = MultipleListPlot[slist1, slist2,
            SymbolShape -> shape[1],
            SymbolStyle -> {{Thickness[0.004 scale], RGBColor[1,0,0]}, {Thickness[0.004 scale], RGBColor[1,0.5,0.5]}},
            PlotRange -> xyrange{{-1, 1}, {-1, 1}},
            AspectRatio -> 1,
            Frame -> True,
            ImageSize -> 400,
            DisplayFunction -> Identity]];
   ];
If[newfigure == True,
      pltseq = {};
      Clear[pol, c, funs];
      (*Cycle over indexes*)
      Do[
        {{n1, n2, n3}, prior, nc} = indlist[[nindlist]];
        c[0] = 1;
        pol[0] = Sum[c[n]z^n, {n, 0, n1}];
        pol[1] = Sum[c[n + n1 + 1]z^n, {n, 0, n2}];
        pol[2] = Sum[c[n + n1 + n2 + 2]z^n, {n, 0, n3}];
        funs[z_] = Sum[cf[[n]]z^(n - 1), {n, nc}];
        (*Quadratic approximant*)
        pattern = pol[0] + pol[1]f[z] + pol[2]f[z]^2;
        eqs = Take[CoefficientList[pattern /. f -> funs, z], nc];
        s = Solve[eqs == Table[0, {nc}], Table[c[n], {n, nc}]];
        ls = Length[s];
        If[ls == 0, Print["No solutions of linear equations found!"]];
        If[ls > 1, Print["More than one solution of linear equations!"]];
        s1 = s[[1]];
        {pa, pb, pc} = {pol[2], pol[1], pol[0]} /. s1;
        pold = pb^2 - 4 pa pc;
        sn = NSolve[pold == 0, z];
        sn = Sort[sn, Abs[((z /. #1) - 0)] < Abs[((z /. #2) - 0)] &];
        sings = z /. sn;
        xylist1 = {Re[#], Im[#]} & /@ sings;
        xylist = 
          Select[xylist1, (Abs[#[[1]]] < 1.05 xyrange && 
                  Abs[#[[2]]] < 1.05 xyrange) &];
        msing = Length[xylist];
        scale = 0.8;
        plt = If[msing == 0, {}, MultipleListPlot[xylist,
            SymbolShape -> shape[2],
            SymbolStyle -> {{Thickness[0.008 scale], color[1]}},
            TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 12, 
                FontSubstitutions -> {"Math1" -> "Symbol"}},
            PlotRange -> xyrange{{-1, 1}, {-1, 1}},
            AspectRatio -> 1,
            Frame -> True,
            ImageSize -> 300,
            DisplayFunction -> Identity]];
        label1 = Graphics[{Text[boxed1["Quadratic"], Scaled[{0.2, 0.95}]]}];
        plt1 = Show[{plt, label1, plts},
            Frame -> True,
            DisplayFunction -> Identity];
        (*Differential approximant*)
        pattern = pol[0] + Sum[pol[k]D[f[z], {z, k - 1}], {k, 2}];
        eqs = Take[CoefficientList[pattern /. f -> funs, z], nc];
        s = Solve[eqs == Table[0, {nc}], Table[c[n], {n, nc}]];
        ls = Length[s];
        If[ls == 0, Print["No solutions of linear equations found!"]];
        If[ls > 1, Print["More than one solution of linear equations!"]];
        s1 = s[[1]];
        nlast = 2;
        pold = pol[2] /. s1;
        sn = NSolve[pold == 0, z];
        sn = Sort[sn, Abs[((z /. #1) - 0)] < Abs[((z /. #2) - 0)] &];
        sings = z /. sn;
        xylist = {Re[#], Im[#]} & /@ sings;
        xylist = 
          Select[xylist, (Abs[#[[1]]] < 1.05 xyrange && 
                  Abs[#[[2]]] < 1.05 xyrange) &];
        msing = Length[xylist];
        scale = 1.0;
        plt = If[msing == 0, {}, MultipleListPlot[xylist,
            SymbolShape -> shape[4],
            SymbolStyle -> {{Thickness[0.008 scale], color[1]}},
            TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 12, 
                FontSubstitutions -> {"Math1" -> "Symbol"}},
            PlotRange -> xyrange{{-1, 1}, {-1, 1}},
            AspectRatio -> 1,
            Frame -> True,
            ImageSize -> 300,
            DisplayFunction -> Identity]];
        label2 = 
          Graphics[{Text[boxed1["Differential"], Scaled[{0.2, 0.95}]]}];
        plt2 = 
          Show[{plt, label2, plts}, Frame -> True, 
            DisplayFunction -> Identity];
        (*Show together*)
wr = 0.1;
plt1r = Rectangle[{0, 0} // Scaled, {(1 - wr)/2, 1} // Scaled, plt1];
plt2r = Rectangle[{(1 - wr)/2, 0} // Scaled, {1 - wr, 1} // Scaled, plt2];
pltind = Table[{{n1, n2, n3}, prior, nc} = indlist[[n]];
      txt = 
        If[n <= mind, 
          "[" <> ToString[n1] <> ", " <> ToString[n2] <> ", " <> 
            ToString[n3] <> "]", ""];
      t = 
        Text[txt, {1/2, 1/2}, 
          TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 14, 
              FontWeight -> If[n == nindlist, "Bold", "Plain"], 
              FontColor -> RGBColor[0, 0, 0.5]}];
      col = 
        If[n > mind, RGBColor[1, 1, 1], 
          If[n == nindlist, RGBColor[1, 1, 0], RGBColor[3/4, 3/4, 3/4]]];
      g = Graphics[t, Background -> col];
      r = 
        Rectangle[{1 - wr, 0.062 + 0.938(mindlist - n)/mindlist} // 
            Scaled, {1, 0.062 + 0.938(mindlist - n + 1)/mindlist} // Scaled, 
          g];
      r, {n, mindlist}];
plt = Show[{plt1r, plt2r, pltind} // Graphics, AspectRatio -> 0.41, ImageSize -> 766, 
    DisplayFunction -> If[ifexport, Identity, $DisplayFunction]];
If[ifexport,
      outfile = ToFileName[dir, sect <>ToString[nindlist] <> ".gif"];
      Export[outfile, plt, "GIF", ImageSize -> 766, ImageResolution -> 72, 
    ConversionOptions -> {"AnimationDisplayTime" -> 1, "Loop" -> True, 
        "ColorReductionPalette" -> 16, "ColorReductionDither" -> False}];
        pltseq = Append[pltseq, plt] ],
        {nindlist, mind}];
If[ifexport,
      outfile = ToFileName[dir, sect <> ".gif"];
      Export[outfile, pltseq, "GIF", ImageSize -> 766, ImageResolution -> 72, 
    ConversionOptions -> {"AnimationDisplayTime" -> 1, "Loop" -> True, 
        "ColorReductionPalette" -> 16, "ColorReductionDither" -> False}];
];
      ];

    "<A NAME=\"" <> sect <> 
        "\"></A><TABLE BORDER=1 CELLPADDING=8 CELLSPACING=0
 BGCOLOR=\"#FFFFFF\"><TR><TD>" // p;
    "<TABLE BORDER=0 CELLPADDING=8 BGCOLOR=\"#FFFFFF\">" // p;
    "<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\" BGCOLOR=\"#FEF8CB\"><TH>
Location of singularities in the complex plane of the parameter <I>z</I>.
<BR>Left panel refers to quadratic approximants,
<BR>right panel to differential approximants." // p;
If[mslist==1,
"<BR>Encircled area is a subjectively estimated location of\n
<BR>the <FONT COLOR=\"#FF0000\">dominant</FONT> singularity
 <I>z</I><SUB>c</SUB>&nbsp;=&nbsp;" <> print2a[singdom,2] <> "." // p ];
If[mslist==2,
"<BR>Encircled areas are subjectively estimated locations of\n
<BR>the <FONT COLOR=\"#FF0000\">dominant</FONT>
 <I>z</I><SUB>c</SUB>&nbsp;=&nbsp;" <> print2a[singdom,2] <> 
" and a <FONT COLOR=\"#FF8080\">subdominant</FONT> <I>z</I>'<SUB>c</SUB>&nbsp;=&nbsp;" <>
 print2a[singsub,2] <> " singularities." // p ];
"<BR>To view an individual approximant, click on the right bar.
<BR>To view all singularities with their weights, see <A HREF=\"sings.htm\">this table</A>.
</TH></TR>" // p;
    "<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\"><TD>" <> "<IMG SRC=\"" <> sect <> 
        ".gif?" <> rndm <> 
        "\" WIDTH=766 HEIGHT=314 BORDER=0 ALT=\"Location of singularities in the
 complex plane\" USEMAP=\"#indbar\"></TD></TR>" <> "</TABLE></TD></TR></TABLE>
<MAP name=\"indbar\">" // p;
x0 = 687;
x1 = 764;
ytop = 0;
ybot = 294;
Do[y1 = ytop + n/mindlist (ybot-ytop);
   y0 = ytop + (n-1)/mindlist (ybot-ytop);
  {x0p, x1p, y0p, y1p} = ToString/@Round/@{x0, x1, y0, y1};
  ref = sect <> ToString[n] <> ".gif?" <> rndm;
  {{n1, n2, n3}, prior, nc} = indlist[[n]];
  app = "[" <> ToString[n1] <> ", " <> ToString[n2] <> ", " <> ToString[n3] <> "]";
"<AREA shape=\"rect\" coords=\"" <> x0p <> ","<> y0p <> ","<> x1p <> ","<> y1p <>
 "\" href=\"" <> ref <> "\" onclick=\"vappr=window.open('" <> ref <>
 "','Singularities" <> (*ToString[n]*)"" <> "','toolbar=no,status=no,scrollbars=no,
location=no,menubar=no,directories=no,width=776,height=324'); vappr.focus(); return false\">" // p;
   , {n, mind}];
"<AREA shape=\"default\" nohref></MAP>" // p;
    printprogr[sect]; printnav, 
    "<A NAME=\"" <> sect <> 
        "\"></A><TABLE BORDER=1 CELLPADDING=8 CELLSPACING=0
 BGCOLOR=\"#FFFFFF\"><TR><TD>" // p;
    "<TABLE BORDER=0 CELLPADDING=8 BGCOLOR=\"#FFFFFF\">" // p;
    "<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\" BGCOLOR=\"#FEF8CB\"><TH>
Singularities of approximants in the complex plane
<BR>are <FONT COLOR=\"#FF0000\">not shown</FONT> for this example (" <> name <>
         ")
<BR>because number of available coefficients of the series (" <> 
        ToString[nm] <> ")
<BR>is too small to construct a meaningful approximant
</TH></TR>
</TABLE></TD></TR></TABLE>" // p;
    "<FONT SIze=\"-2\"><A HREF=\"#top\">
<IMG SRC=\"../../../../iconz/top.gif\" WIDTH=13 HEIGHT=9 BORDER=0
 ALT=\"Top of Page\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;
<A HREF=\"#top\">Top&nbsp;of&nbsp;the&nbsp;page</A>
&nbsp;&nbsp;&nbsp;&nbsp;" // p;
    If[nser != 1, namem = names[[nser - 1]];
      nameml = StringReplace[ToLowerCase[namem], "+" -> "-"];
      ref = "../" <> nameml <> "/index.htm#" <> sect;
      "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"" <> ref <> 
          "\"><IMG SRC=\"../../../../iconz/top270.gif\" WIDTH=9 HEIGHT=13
BORDER=0 ALT=\"Previous Example\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;
<A  HREF=\"" <> ref <> "\">Prev.&nbsp;(" <> namem <> ")</A>" // p];
    "&nbsp;&nbsp;&nbsp;&nbsp;<IMG SRC=\"../../../../blank.gif\" WIDTH=13
 HEIGHT=9 BORDER=0 ALT=\"Blank\" ALIGN=\"MIDDLE\">&nbsp;&nbsp;Current&nbsp;(" <>
         name <> ")" // p;
    If[nser != mser, namep = names[[nser + 1]];
      namepl = StringReplace[ToLowerCase[namep], "+" -> "-"];
      ref = "../" <> namepl <> "/index.htm#" <> sect;
      "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"" <> ref <> 
          "\"><IMG SRC=\"../../../../iconz/top90.gif\" WIDTH=9 HEIGHT=13
 BORDER=0 ALT=\"Next Example\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;<A HREF=\"" <> 
          ref <> "\">Next&nbsp;(" <> namep <> ")</A>" // p];
    "&nbsp;&nbsp;&nbsp;&nbsp;" // p;
    "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"../" <> sect <> 
        ".htm\"><IMG SRC=\"../../../../iconz/smalldig.gif\" WIDTH=12
 HEIGHT=17 BORDER=0 ALT=\"Mathematica program\"
 ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;<A HREF=\"../" <> sect <> 
        ".htm\"><I>Mathematica</I>&nbsp;program</A>" // p;
    "</FONT><BR><BR>" // p;];

Molecule - icon for Allen-dataBlankExamples of MP seriesBlankSource code of Mathematica programBlankMathematica programsBlankWork in UMass DartmouthWork in UMassDBlankWaste iconUnpublished reports

Designed by A. Sergeev.