TransWikia.com

How to derive a 3D interpolated surface?

Mathematica Asked on December 17, 2020

I want to derive a surface I interpolated which lies in 3D. However my use of Derivative does not seem to work and I don’t understand why.
What I want is to calculate and plot the derivative of this surface :
enter image description here

I tried to use :

 DINHA = Flatten[
   ParallelTable[{x, y,  
     Derivative[1, 0][INHA][x, y] + Derivative[0, 1][INHA][x, y]}, {x,
      1, 201, 10}, {y, 1, 101, 10}], 1];

But it is taking a lot of memory and when I tried to reduce the number of points it gives me a pixelated result.

ListPlot3D[DINHA]

enter image description here

What do I do wrong ? Can’t I derive an interpolated surface which equal to a new interpolation which I can plot ?

You want to Plot the same surface: (Don’t be afraid by the length it is not complicated. There is a big matrix to define then I find the zeros of the determinant then I plot one of the two surface of zeros and this is this surface that I want to derive)

     Mraw[ϵ_, δg_, δd_, U_, L_, 
  k_, κ0_] = ({{u[ϵ, δg]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], 
    v[ϵ, -δg]*
     Exp[-I*L/2*(k - κ[ϵ, κ0])], -u[ϵ,
        0]*Exp[-I*
       L/2*(k + κ[ϵ, κ0])], -u[ϵ, 0]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], -v[ϵ, 
       0]*Exp[-I*
       L/2*(k - κ[ϵ, κ0])], -v[ϵ, 0]*
     Exp[I*L/2*(k - κ[ϵ, κ0])], 0, 
    0}, {v[ϵ, δg]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], 
    u[ϵ, -δg]*
     Exp[-I*L/2*(k - κ[ϵ, κ0])], -v[ϵ,
        0]*Exp[-I*
       L/2*(k + κ[ϵ, κ0])], -v[ϵ, 0]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], -u[ϵ, 
       0]*Exp[-I*
       L/2*(k - κ[ϵ, κ0])], -u[ϵ, 0]*
     Exp[I*L/2*(k - κ[ϵ, κ0])], 0, 0}, {0, 
    0, -u[ϵ, 0]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], -u[ϵ, 
       0]*Exp[-I*
       L/2*(k + κ[ϵ, κ0])], -v[ϵ, 0]*
     Exp[I*L/2*(k - κ[ϵ, κ0])], -v[ϵ, 
       0]*Exp[-I*L/2*(k - κ[ϵ, κ0])], 
    u[ϵ, δd]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], 
    v[ϵ, -δd]*
     Exp[-I*L/2*(k - κ[ϵ, κ0])]}, {0, 
    0, -v[ϵ, 0]*
     Exp[I*L/2*(k + κ[ϵ, κ0])], -v[ϵ, 
       0]*Exp[-I*
       L/2*(k + κ[ϵ, κ0])], -u[ϵ, 0]*
     Exp[I*L/2*(k - κ[ϵ, κ0])], -u[ϵ, 
       0]*Exp[-I*L/2*(k - κ[ϵ, κ0])], 
    v[ϵ, 

 1. δd]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], 
        u[ϵ, -δd]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])]}, {(1 + I*U)*
         u[ϵ, δg]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         v[ϵ, -δg]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])], (1 + I*U)*
         u[ϵ, 0]*
         Exp[-I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         u[ϵ, 0]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (1 + I*U)*
         v[ϵ, 0]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])], (-1 + I*U)*
         v[ϵ, 0]*
         Exp[I*L/2*(k - κ[ϵ, κ0])], 0, 
        0}, {(1 + I*U)*v[ϵ, δg]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         u[ϵ, -δg]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])], (1 + I*U)*
         v[ϵ, 0]*
         Exp[-I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         v[ϵ, 0]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (1 + I*U)*
         u[ϵ, 0]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])], (-1 + I*U)*
         u[ϵ, 0]*
         Exp[I*L/2*(k - κ[ϵ, κ0])], 0, 0}, {0, 
        0, (-1 + I*U)*u[ϵ, 0]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (1 + I*U)*
         u[ϵ, 0]*
         Exp[-I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         v[ϵ, 0]*
         Exp[I*L/2*(k - κ[ϵ, κ0])], (1 + I*U)*
         v[ϵ, 0]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])], (1 + I*U)*
         u[ϵ, δd]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         v[ϵ, -δd]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])]}, {0, 
        0, (-1 + I*U)*v[ϵ, 0]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (1 + I*U)*
         v[ϵ, 0]*
         Exp[-I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         u[ϵ, 0]*
         Exp[I*L/2*(k - κ[ϵ, κ0])], (1 + I*U)*
         u[ϵ, 0]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])], (1 + I*U)*
         v[ϵ, δd]*
         Exp[I*L/2*(k + κ[ϵ, κ0])], (-1 + I*U)*
         u[ϵ, -δd]*
         Exp[-I*L/2*(k - κ[ϵ, κ0])]}});  u[ϵ_, δ_] = (E^(I δ/2) Sqrt[
         1 + Sqrt[1 - 1/ϵ^2]])/Sqrt[2]; v[ϵ_, δ_] = (E^(-I δ/2) Sqrt[
          1 - Sqrt[1 - 1/ϵ^2]])/Sqrt[2]; κ[ϵ_, κ0_] = κ0*Sqrt[ϵ^2 - 1]; δd0 =.;
    δg0 =.; U0 = 0.25; L0 = 0.5; Lmax = 10; k0 = (2 π/10^-4 +
    π/2*0)/L0; κ00 = 1/1; δdstep = 0.01; δgstep
    = 0.005; δstep = 0.01; ϵ0 =.; x0 = -L0/2; ϵstep = 0.01;
    
    MyMrawDet[ϵ_, δg_, δd_, U_, L_,     k_,
    κ0_] :=    Det[Mraw[ϵ, δg, δd, U, L,
    k, κ0]]; tempdet =    ParallelTable[   
    MyMrawDet[ϵ0, δg0, δd0, U0, L0, 
        k0/L0, κ00], {ϵ0, 0 + ϵstep, 
        1 - ϵstep, ϵstep}, {δg0, 0, 2 π, 
        2 π*δgstep}, {δd0, 0, 2 π, 
        2 π*δdstep}];
    
    AP = ParallelTable[   Sign[Re[tempdet]][[p + 1]] -
    Sign[Re[tempdet]][[p]], {p, 1,     First[Dimensions[tempdet]] - 1,
    1}]; HighAP =   DeleteDuplicates[   Position[Re[
        AP], -2], #1[[2]] == #2[[2]] && #1[[3]] == #2[[3]] && #1[[1]] < 
    #2[[1]] &]; NHA = ParallelTable[    RotateLeft[HighAP[[x]]], {x, 1, First[Dimensions[HighAP]], 1}]; INHA = Interpolation[NHA]; Plot3D[ 
    INHA[x, y], {x, 1, 201}, {y, 1, 101}]

Thank you for your help

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP