
(*inverse stereographic projection*)
s[x_, y_] := {(2*x)/(1 + x*x + y*y), (2*y)/(1 + x*x + y*y), 1 - 2/(1 + x*x + y*y)};


(*These are the two basic functions making up the energy potential function*)

F[x1_,y1_,EXP_]:=(
a=s[x1,y1];
b={0,0,1};
c=(a-b).(a-b);
Power[4-c,EXP])

G[x1_,y1_,x2_,y2_,EXP_]:=(
a=s[x1,y1];
b=s[x2,y2];
c=(a-b).(a-b);
Power[4-c,EXP])

(*Here is the energy function*)

ff[x0_,x1_,y1_,x2_,y2_,x3_,y3_,EXP_]:=(
list1={
F[x0,0,EXP],
F[x1,y1,EXP],
F[x2,y2,EXP],
F[x3,y3,EXP],
G[x0,0,x1,y1,EXP],
G[x0,0,x2,y2,EXP],
G[x0,0,x3,y3,EXP],
G[x1,y1,x2,y2,EXP],
G[x1,y1,x3,y3,EXP],
G[x2,y2,x3,y3,EXP]};
Sum[list1[[j]],{j,1,10}])


(**Here J is a multi-index*)

DER[J_,EXP_]:=(
(*The basic expression*)
a1=ff[x0,x1,y1,x2,y2,x3,y3,EXP];
VAR={x0,x1,y1,x2,y2,x3,y3};
count=1;
Clear[x0,x1,y1,x2,y2,x3,y3];
While[count<=Length[J],{a1=D[a1,VAR[[J[[count]]]]];++count}];
{x0,x1,y1,x2,y2,x3,y3}={1,0,0,-1/2,Sqrt[3]/2,-1/2,-Sqrt[3]/2};
a2=a1;
Clear[x0,x1,y1,x2,y2,x3,y3];
a2)

(*
This computes gives the final bound on the third
derivatives.  Here are the inequalities we want.

FinalBound[2,500]<1
FinalBound[3,500]<1
FinalBound[4,500]<2
FinalBound[5,500]<4
FinalBound[6,500]<12
FinalBound[10,1600]<1091

This is what we need to get the positive definite
bound throughout the neighborhood B0
*)


d1[m_]:=Flatten[Table[Table[Table[DER[{i,j,k},m],{i,1,7}],{j,1,7}],{k,1,7}]]
d2[m_,ERR_]:=Abs[d1[m]] + ERR;

FinalBound[m_,ERR_]:=(
LIST=d2[m,ERR];
Sqrt[LIST.LIST] Sqrt[7] Power[2,-15])
