(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
   Mathematica code computes an approximate solution by multiple-precision and 
   obtain its residual and related norms by rational arithmetic.
   version 2023.03.06
 -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)
Clear["Global`*"]
prec = 1000;   (* precision for floating point number operation *)
cri = 10^(-20) (* criterion of Newton-Raphson iteration *)
itmax = 500;   (* maximum iteretion number for Newton-Raphson iteretion *)

K = 20;   (* truncation number of Ledgendre polynomial *)
R = 1;    (* Reynolds number *)
e = -1;   (* parameter for the function g(X) *)
A = 1;    (* permeable (A=1) or impermeable (A=0) parameter *)
Print[" K = ",K];
Print[" R = ",R];
Print[" e = ",e];
Print[" A = ",A];

(* ----- setting initial guess ----- *)
uh = Table[0,{i,K}];
uh[[1]] = 1;
uh[[2]] = -3;
uh[[3]] = -5;
uh[[4]] = 1;
(*
uh[[1]] = RandomInteger[{-K,K}]/K;
uh[[2]] = RandomInteger[{-K,K}]/K^2;
uh[[3]] = RandomInteger[{-K,K}]/K^3;
*)
(* uh =<< app-R4.dat; *) (* initial guess *) 


(* ----- generating or reading matrices ----- *)
DD = IdentityMatrix[K];
G0 = Get["G0_"<>ToString[K]<>".dat"];
G3 = Get["G3_"<>ToString[K]<>".dat"];
G4 = Get["G4_"<>ToString[K]<>".dat"];
 h = Get["h_"<>ToString[K]<>".dat"];


(* ----- Translating floating presicion ----- *)
G0 = N[G0,prec]; G3 = N[G3,prec]; G4 = N[G4,prec]; h = N[h,prec];


(* ----- Newton-Raphson iteration ----- *)
Do[
   G1 = Table[0,{i,K},{j,K}]; G2 = G1;
   Do[
     Do[
       Do[
         G1[[i,j]] = G1[[i,j]] + G0[[i,j,k]] uh[[k]];
         G2[[i,j]] = G2[[i,j]] + G0[[i,k,j]] uh[[k]];
       ,{k,1,K}
       ],{i,1,K}
     ], {j,1,K}
    ];
   G = DD - R (G1 + G2 + G3 + G4);
   f = (DD - R (G2 + G3 + G4)).uh + h;
   Print["No.",s,":   error: ",N[Norm[f]/Norm[uh],10]]; 
   If [ Norm[f]/Norm[uh] < cri, Break[] ];
   If [ Norm[f]/Norm[uh] > 10^3, Quit[] ];
   uh = uh - LinearSolve[G,f];
   uh = Chop[uh,10^-20]; 
,{s,itmax}]


(* ----- Computing approximate condition number ----- *)
U = N[G,20];
Print["Condition Number of G: ", Norm[U]*Norm[Inverse[U]]];


(* ----- Computing residual with rational number arithmetic ----- *)
uh = Rationalize[Chop[uh,cri],0];
psi[m_] := (-1)^(m+1)/(m+1)! /2^(m+1) Sqrt[(2m+3)/2] D[(1-x^2)^(m+1),{x,m-1}];
g = e(1-x^2)^2 + (A-1)/2 x^2(2-x^2) + (A+1)/4 x(3-x^2);

u = 0;
Do[ u = u + uh[[i]] psi[i];,{i,1,K} ]
u = Factor[Expand[u]];
rh = Expand[ D[u+g,{x,4}] - R D[u+g,{x,3}](u+g)];
res = Sqrt[Integrate[Expand[rh^2],{x,-1,1}]];
Print["L2-norm of residual: ",N[res,20]]; 


(* ----- Computing each norms ----- *)
g1 = MaxValue[Abs[g], -1<=x<=1, x];         (* Infinity-norm of g *)
rh = Expand[D[u,{x,1}]]; 
d1 = Sqrt[Integrate[Expand[rh^2],{x,-1,1}]]; (* L2-norm of uh^(1) *)
infw0 = g1 + d1/Sqrt[2];                    (* infinity-norm of w_h *)
Print["Inf-norm of wh: ",N[infw0,20]]; 

w = u + g;
rh = Expand[D[w,{x,2}]]; 
w2 = Sqrt[Integrate[Expand[rh^2],{x,-1,1}]]; (* L2-norm of uh^(2) *)
infw1 = w2/Sqrt[2];
Print["Inf-norm of wh^(1): ",N[infw1,20]];  (* infinity-norm of w_h^(1) *)

rh = Expand[D[w,{x,3}]]; 
w3 = Sqrt[Integrate[Expand[rh^2],{x,-1,1}]]; (* L2-norm of uh^(3) *)
infw2 = Sqrt[w2^2+4*w3^2];
Print["Inf-norm of wh^(2): ",N[infw2,20]];  (* infinity-norm of w_h^(2) *)

rh = Expand[D[w,{x,4}]]; 
w4 = Sqrt[Integrate[Expand[rh^2],{x,-1,1}]]; (* L2-norm of uh^(4) *)
infw3 = Sqrt[w3^2+4*w4^2];
Print["Inf-norm of wh^(3): ",N[infw3,20]];  (* infinity-norm of w_h^(3) *)

c3[L_] := 1 / ( Sqrt[2L-5] (2L-3) (2L-1) (2L+1) Sqrt[2L+3] ) + 
          4 / ( (2L-3) Sqrt[2L-1] (2L+1) Sqrt[2L+3] (2L+5) ) + 
          6 / ( (2L-1) (2L+1) (2L+5) (2L+7) ) + 
          4 / ( (2L+1) Sqrt[2L+3] (2L+5) Sqrt[2L+7] (2L+9) ) + 
          1 / ( Sqrt[2L+3] (2L+5) (2L+7) (2L+9) Sqrt[2L+11] );
Ch = Sqrt[c3[K+3]];
c2 = 4/Pi^2;
c4 = 4*Sqrt[2]/Pi^2;
delta = c2*res;
tau1 = Abs[R]*(Ch(3*Sqrt[c2]*infw2+2*infw1)+Sqrt[Ch]*infw0);
tau2 = Abs[R]*(Ch(c2*infw3+infw1)+Sqrt[Ch]*infw0);
tau3 = Abs[R]*(Ch(Ch*infw3+infw1)+Sqrt[Ch]*infw0);


(* ----- Generating verified matrix G ----- *)
G0 = Get["G0_"<>ToString[K]<>".dat"];
G3 = Get["G3_"<>ToString[K]<>".dat"];
G4 = Get["G4_"<>ToString[K]<>".dat"];
G1 = Table[0,{i,K},{j,K}]; G2 = G1;
Do[
  Do[
    Do[
      G1[[i,j]] = G1[[i,j]] + G0[[i,j,k]] uh[[k]];
      G2[[i,j]] = G2[[i,j]] + G0[[i,k,j]] uh[[k]];
    ,{k,1,K}
    ],{i,1,K}
  ], {j,1,K}
 ];
G = DD - R (G1 + G2 + G3 + G4);

(* ----- Writing INTLAB/MATLAB code ----- *)
fname = "verify_R"<>ToString[R]<>"_A"<>ToString[A]<>"_K"<>ToString[K]<>".m";
s = OpenWrite[File[fname], PageWidth->100];
WriteString[s,"R = ",R,";\n"];
WriteString[s,"K = ",K,";\n"];
WriteString[s,"G = intval(zeros(K,K));\n"];
Do[Do[
  WriteString[s,"G(",i,",",j,")=intval('",FortranForm[N[G[[i,j]],50]],"');\n"]; 
  ,{i,1,K}], {j,1,K}]
WriteString[s,"  rho = norm(inv(G));\n"];
WriteString[s," tau1 = intval('",FortranForm[N[tau1,50]],"');\n"]; 
WriteString[s," tau2 = intval('",FortranForm[N[tau2,50]],"');\n"]; 
WriteString[s," tau3 = intval('",FortranForm[N[tau3,50]],"');\n"]; 
WriteString[s,"   c4 = intval('",FortranForm[N[c4,50]],"');\n"]; 
WriteString[s,"delta = intval('",FortranForm[N[delta,50]],"');\n"]; 
WriteString[s,"fprintf('                  R:%15.5e\\n',R)\n"]; 
WriteString[s,"fprintf('                  K:%15.5e\\n',K)\n"]; 
WriteString[s,"fprintf('                rho:%15.5e\\n',sup(rho))\n"]; 
WriteString[s,"kappa = rho*tau1*tau2 + tau3;\n"]; 
WriteString[s,"fprintf('               tau1:%15.5e\\n',sup(tau1))\n"]; 
WriteString[s,"fprintf('               tau2:%15.5e\\n',sup(tau2))\n"]; 
WriteString[s,"fprintf('               tau3:%15.5e\\n',sup(tau3))\n"]; 
WriteString[s,"fprintf('              kappa:%15.5e\\n',sup(kappa))\n"]; 
WriteString[s,"if sup(kappa)<1"]; 
WriteString[s,"  M = 1/(1-kappa)*norm([rho*(1-tau3) rho*tau1; rho*tau2 1]);\n"]; 
WriteString[s,"  fprintf('                  M:%15.5e\\n',sup(M))\n"]; 
WriteString[s,"  beta = 4*M^2*abs(R)*c4*delta;\n"]; 
WriteString[s,"  fprintf('               beta:%15.5e\\n',sup(beta))\n"]; 
WriteString[s,"  if sup(beta)<1\n"]; 
WriteString[s,"    We = (1-sqrt(1-beta))/(2*M*abs(R)*c4);\n"]; 
WriteString[s,"    Wu = (1+sqrt(1-beta))/(2*M*abs(R)*c4);\n"];  
WriteString[s,"    fprintf('                 We:%15.5e\\n',inf(We))\n"]; 
WriteString[s,"    fprintf('                 Wu:%15.5e\\n',inf(Wu))\n"]; 
WriteString[s,"  end\n"]; 
WriteString[s,"else\n"]; 
WriteString[s,"  fprintf('Invertibility of L can not be validated\\n')\n"]; 
WriteString[s,"end\n"]; 
Close[s];


(* ----- Plotting graphics ----- *)
fname = "wh_R"<>ToString[R]<>"_A"<>ToString[A]<>"_K"<>ToString[K]<>".pdf";
s = N[Expand[w],100];              (* w = uh+g *)
Export[fname,Plot[s,{x,-1,1}]];

fname = "SDP_R"<>ToString[R]<>"_A"<>ToString[A]<>"_K"<>ToString[K]<>".pdf";
vr = -R r D[s, x]/2;
vz = R s;
Export[fname,StreamDensityPlot[{vr,vz},{r,-3,3},{x,-1,1},
PlotLegends -> Automatic, AspectRatio -> Automatic]]

fname = "Dwh_R"<>ToString[R]<>"_A"<>ToString[A]<>"_K"<>ToString[K]<>".pdf";
s = N[Expand[D[w,x]],100];        
Export[fname,Plot[s,{x,-1,1}]];
Dateobject[]
