Useful programs

Mathematica program

(* Useful programs *)

<< algappr.m;

<< Graphics`; 
<< Calculus`Pade`;

(* Printing in FORTRAN format(Fm.n) *)
printF[x_Real,m_Integer,n_Integer]:=
Module[{c,l,r},
c=10^n;
l=m-2;
r=FortranForm[Round[c x]/c];
ToString[PaddedForm[r,{l,n},ExponentFunction->(Null&)]]
];

(* Printing in fixed point format *)
print0[x_Real]:=
"&nbsp;" <> ToString[NumberForm[SetAccuracy[x, accDigits[x] + 0.5], 
  ExponentFunction -> (Null &), DigitBlock -> 3, NumberSeparator -> "&nbsp;",
NumberSigns -> {"-", "&nbsp;"}]] <> "&nbsp;";

(* Printing real or complex numbers in Fortran format *)
print2a[x_Real, n_] := SetAccuracy[x, n+1] // FortranForm // ToString;
print2a[x_Complex, n_] := (
{xr, xi} = {Re[x], Im[x]};
If[xr==0, print2a[xi, n] <> " <I>i</I>",
print2a[xr, n] <> If[xi>0, " + ", " - "] <> print2a[Abs[xi], n] <> " <I>i</I>"]);
print2p[x_Real, n_] := SetPrecision[x, n] // FortranForm // ToString;
print2p[x_Complex, n_] := (
{xr, xi} = {Re[x], Im[x]};
If[xr==0, print2p[xi, n] <> " <I>i</I>",
print2p[xr, n] <> If[xi>0, " + ", " - "] <> print2p[Abs[xi], n] <> " <I>i</I>"]);

rndm := ToString[Random[Integer, {0, 999999}]];

open[s_String] := If[ifwrite, OpenWrite[s, PageWidth -> Infinity, FormatType -> OutputForm]];
p[s_String] := If[ifwrite, Write[of, s]];
close[s] := If[ifwrite, Close[s]];

removetag[s_String] := Module[{s1, sp1, sp2, p1, p2},
      s1 = s;
      While[
        {sp1, sp2} = {sp1, sp2} = {StringPosition[s1, "<", 1], StringPosition[s1, ">", 1]};
        (sp1 =!= {} && sp2 =!= {}) && ((p1 = sp1[[1, 1]]) < (p2 = sp2[[1, 1]])),
        s1 = StringDrop[s1, {p1, p2}]];
      s1];

Discriminant[p_?PolynomialQ, x_] := 
    With[{n = Exponent[p, x]}, 
      Cancel[((-1)^(n(n - 1)/2)Resultant[p, D[p, x], x])/
          Coefficient[p, x, n]^(2n - 1)]];

sumser[x_, ns_] := (
      If[ns > Length[func], Return["Undetermined"]];
      If[x == 0, Return[func[[1]]]];
      Sum[func[[n]]x^(n - 1), {n, ns}]);
padesum[x_, ns_] := Module[{z},
      If[ns > Length[func], Return["Undetermined"]];
      If[x == 0, Return[func[[1]]]];
      npadenum = Floor[(ns - 1)/2];
      npadeden = ns - 1 - npadenum;
      Pade[sumser[z, ns], {z, 0, npadenum, npadeden}] /. z -> x
      ];

shape[0] := MakeSymbol[Disk[{0, 0}, Offset[5 scale{1, 1}]]];(*partial sums*)
shape[1] := 
    MakeSymbol[
      Circle[{0, 0}, Offset[6 scale{1, 1}]]];(*linear (Pade) approximants*)
shape[2] := PlotSymbol[Box, 5 scale];(*quadratic*)
shape[3] := PlotSymbol[Triangle, 6 scale];(*cubic*)
shape[4] := PlotSymbol[Diamond, 6 scale];(*quartic*)
shape[5] := PlotSymbol[Star, 6 scale];(*5th order*)
shape[6] := 
    MakeSymbol[{RegularPolygon[6, 6 scale, {0, 0}, 0, 2], 
        RegularPolygon[6, 6 scale, {0, 0}, Pi/3, 2]}];(*6th order*)
color[n_] := RGBColor[0, 0, 0];
color[0] := RGBColor[1, 0, 0];
color[1] := RGBColor[0, 0, 1];
color[2] := RGBColor[0, 1, 0];

(* Printing navigation line at bottom of each table or figure *)
printnav := If[ifwrite, 
"<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];
If[entity === "table" && nm>30, "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"#" <> sect <> "\"><IMG SRC=\"../../../../iconz/top.gif\" WIDTH=13 HEIGHT=9 BORDER=0 ALT=\"Top of" <> entity <> "\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;<A HREF=\"#" <> sect <> "\">Top&nbsp;of&nbsp;this&nbsp;" <> entity <> "&nbsp;(" <> name <> ")</A>" // 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;
If[entity === "figure" && sect != "sings3" && sect != "function", "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"" <> sect <> ".pdf\"><IMG SRC=\"../../../../iconz/pdf.gif\" WIDTH=16 HEIGHT=16 BORDER=0 ALT=\"PDF format for printing\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;<A HREF=\"" <> sect <> ".pdf\">PDF&nbsp;format</A>" // 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;
];

(* Printing Mathematica program in HTML-format *)
htmlrepl[s_String] := StringReplace[s, {"<"->"&lt;", ">"->"&gt;", "&"->"&amp;", "\""->"&quot;"}];
flankblank[s_String]:=
Module[{s0,s9},
 If[s=="",s,
  If[s0=StringTake[s,1];s0==" "||s0=="\n",flankblank[StringDrop[s,1]],
   If[s9=StringTake[s,-1];s9==" "||s9=="\n",flankblank[StringDrop[s,-1]],s]]]
       ];

printprogrs = {};
printprogr[sect_String] := If[ifwrite, If[!MemberQ[printprogrs, sect],
progfile = ToFileName[dirhome, sect <> ".m"];
progtext = Import[progfile, "Text"];
sp1 = StringPosition[progtext, "(*"];
sp2 = StringPosition[progtext, "*)"];
progtitle = 
  If[sp1 =!= {} && sp2 =!= {}, 
    StringTake[progtext, {sp1[[1, 2]] + 1, sp2[[1, 1]] - 1}], ""];
{progtext,progtitle} = htmlrepl/@flankblank/@{progtext,progtitle};
outfile = ToFileName[dirhtml, sect <> ".htm"];
ofprev = of;
of = open[outfile];
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\">\n
<HTML><HEAD>\n
<TITLE>" <> progtitle <> "</TITLE>\n
<META http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\">\n
<META name=\"description\" content=\"Source text of Mathematica program used for study of MP perturbation series\">\n
<META name=\"keywords\" content=\"Mathematica, programming, computation, Moller Plesset perturbation theory, summation, Pade approximants\">\n
</HEAD><BODY BACKGROUND=\"../../../iconz/bg-calc.gif\">\n
<H1>" <> progtitle <> "</H1>\n
<H2><I>Mathematica</I> program</H2>\n
<TABLE BORDER=0 CELLSPACING=0 CELLPADDING=10 BGCOLOR=\"#FEF8CB\"><TR>\n
<TD><PRE>" <> progtext <> "</PRE></TD></TR></TABLE>\n
<BR>" // p;
refbarm = "<TABLE BORDER=0 CELLSPACING=0 CELLPADDING=0><TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\"><TD NOWRAP>
<A HREF=\"index.htm\">
<IMG SRC=\"../../../iconz/molec1.gif\" WIDTH=36 HEIGHT=41 BORDER=0 ALIGN=\"ABSMIDDLE\" ALT=\"Molecule - icon for Allen-data\">
<IMG SRC=\"../../../blank.gif\" WIDTH=2 HEIGHT=1 BORDER=0 ALIGN=\"ABSMIDDLE\" ALT=\"Blank\">Examples of MP series</A>
<IMG SRC=\"../../../blank.gif\" WIDTH=32 HEIGHT=1 ALT=\"Blank\">
<A HREF=\"proglist.htm\">
<IMG SRC=\"../../../iconz/mathemat.gif\" WIDTH=17 HEIGHT=16 BORDER=0 ALIGN=\"MIDDLE\" ALT=\"Source code of Mathematica program\">
<IMG SRC=\"../../../blank.gif\" WIDTH=5 HEIGHT=1 BORDER=0 ALIGN=\"ABSMIDDLE\" ALT=\"Blank\"><I>Mathematica</I> programs</A>
<IMG SRC=\"../../../blank.gif\" WIDTH=32 HEIGHT=1 ALT=\"Blank\">
<A HREF=\"../index.htm\">
<IMG SRC=\"../../../iconz/whale.gif\" WIDTH=40 HEIGHT=35 BORDER=0 ALIGN=\"ABSMIDDLE\" ALT=\"Work in UMass Dartmouth\">Work in UMassD</A>
<IMG SRC=\"../../../blank.gif\" WIDTH=32 HEIGHT=1 ALT=\"Blank\">
<A HREF=\"../../reports.htm\">
<IMG SRC=\"../../waste.gif\" WIDTH=32 HEIGHT=43 BORDER=0 ALIGN=\"ABSMIDDLE\" ALT=\"Waste icon\">Unpublished reports</A>
</TD></TR></TABLE>";
refbarm = StringReplace[refbarm, "> <"->"><"];

refbarm // p;
"<HR>" // p;

"<P><FONT SIZE=\"-2\">Designed by <A HREF=\"../../../index.htm\">A. Sergeev</A></FONT>.</P>\n
</BODY>\n
</HTML>" // p;
Close[outfile];
of = oproglist;
"<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\" BGCOLOR=\"#" <> If[EvenQ[Length[printprogrs]],"FFFFFF","E0E0E0"] <> "\">\n
<TD><TT><A HREF=\"" <> sect <> ".htm\">" <> sect <> "</A></TT></TD>\n
<TD>" <> progtitle <> "</TD></TR>" // p;
of = ofprev;
printprogrs = Append[printprogrs, sect];
]];

(* Starting list of Mathematica programs *)
If[ifwrite, 
proglistfile = ToFileName[dirhtml, "proglist.htm"];
oproglist = open[proglistfile];
mainfile = ToFileName[dirhome, "main.m"];
maintext = Import[mainfile, "Text"];
sp1 = StringPosition[maintext, "(*"];
sp2 = StringPosition[maintext, "*)"];
maintitle = 
  If[sp1 =!= {} && sp2 =!= {}, 
    StringTake[maintext, {sp1[[1, 2]] + 1, sp2[[1, 1]] - 1}], ""];
{maintext,maintitle} = htmlrepl/@flankblank/@{maintext,maintitle};
(* Currently maintitle is not used *)
plist = "
<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\">\n
<HTML>\n
<HEAD>\n
<TITLE>Programs to display results of summation of Moller-Plesset perturbation series as web-pages</TITLE>\n
<meta http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\">\n
<META name=\"description\" content=\"Texts of programs for Mathematica software used to calculate and display coefficients of Moller-Plesset perturbation theory, partial sums, Pade approximants, singularities etc.\">\n
<META name=\"keywords\" content=\"quantum mechanics, Moller Plesset perturbation theory, summation, Pade approximants\">\n
</HEAD>\n
<BODY BACKGROUND=\"../../../iconz/bg-calc.gif\">\n
<H1><I>Mathematica</I> programs to display results of summation of M&#248;ller-Plesset perturbation series as web-pages</H1>\n
\n
<H2>Main program</H2>\n
<TABLE BORDER=0 CELLSPACING=0 CELLPADDING=10 BGCOLOR=\"#FEF8CB\"><TR>\n
<TD><PRE>" <> maintext <>
"</PRE></TD></TR></TABLE>\n
\n
<H2>Sub-programs</H2>\n
<TABLE BORDER=0 CELLSPACING=1 CELLPADDING=5 BGCOLOR=\"C0C0C0\">\n
<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\" BGCOLOR=\"#FFFFFF\">";
Write[oproglist,plist];
];

printprogr["programs"];

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

Designed by A. Sergeev.