# 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]:= " " <> ToString[NumberForm[SetAccuracy[x, accDigits[x] + 0.5], ExponentFunction -> (Null &), DigitBlock -> 3, NumberSeparator -> " ", NumberSigns -> {"-", " "}]] <> " "; (* 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", print2a[xr, n] <> If[xi>0, " + ", " - "] <> print2a[Abs[xi], n] <> " 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", print2p[xr, n] <> If[xi>0, " + ", " - "] <> print2p[Abs[xi], n] <> " 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]]; 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, "  Top of the page    " // p; If[nser != 1, namem = names[[nser-1]]; nameml = StringReplace[ToLowerCase[namem], "+" -> "-"]; ref = "../" <> nameml <>"/index.htm#" <> sect; "     ref <> "\">   ref <> "\">Prev. (" <> namem <> ")" // p]; If[entity === "table" && nm>30, "     sect <> "\"> entity <> "\" ALIGN=\"MIDDLE\">   sect <> "\">Top of this " <> entity <> " (" <> name <> ")" // p]; If[nser != mser, namep = names[[nser+1]]; namepl = StringReplace[ToLowerCase[namep], "+" -> "-"]; ref = "../" <> namepl <>"/index.htm#" <> sect; "     ref <> "\">   ref <> "\">Next (" <> namep <> ")" // p]; "    " // p; If[entity === "figure" && sect != "sings3" && sect != "function", "     sect <> ".pdf\">   sect <> ".pdf\">PDF format" // p]; "     sect <> ".htm\">   sect <> ".htm\">Mathematica program" // p; "

" // p; ]; (* Printing Mathematica program in HTML-format *) htmlrepl[s_String] := StringReplace[s, {"<"->"<", ">"->">", "&"->"&", "\""->"""}]; 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]; "\n \n " <> progtitle <> "\n \n \n \n \n

" <> progtitle <> "

\n

Mathematica program

\n
" <> progtext <> "
\n \n
" // p; refbarm = "
Examples of MP series Mathematica programs Work in UMassD Unpublished reports
"; refbarm = StringReplace[refbarm, "> <"->"><"]; refbarm // p; "
" // p; "

Designed by A. Sergeev.

\n \n " // p; Close[outfile]; of = oproglist; "
sect <> ".htm\">" <> sect <> "" <> progtitle <> "
" <> maintext <> "
If[EvenQ[Length[printprogrs]],"FFFFFF","E0E0E0"] <> "\">\n \n " // 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 = " \n \n \n Programs to display results of summation of Moller-Plesset perturbation series as web-pages\n \n \n \n \n \n

Mathematica programs to display results of summation of Møller-Plesset perturbation series as web-pages

\n \n

Main program

\n \n \n \n

Sub-programs

\n \n
"; Write[oproglist,plist]; ]; printprogr["programs"];```

 Examples of MP seriesMathematica programsWork in UMassDUnpublished reports

Designed by A. Sergeev.