perf(polin3): switch to lagrange-weight tensor contraction

AMSS_NCKU_source/fmisc.f90

@@ -1244,6 +1244,41 @@ end subroutine d2dump
   return
   end subroutine polint
 !------------------------------------------------------------------------------
+! Compute Lagrange interpolation basis weights for one target point.
+!------------------------------------------------------------------------------
+!DIR$ ATTRIBUTES FORCEINLINE :: polint_lagrange_weights
+  subroutine polint_lagrange_weights(xa, x, w, ordn)
+  implicit none
+
+  integer, intent(in) :: ordn
+  real*8, dimension(1:ordn), intent(in) :: xa
+  real*8, intent(in) :: x
+  real*8, dimension(1:ordn), intent(out) :: w
+
+  integer :: i, j
+  real*8 :: num, den, dx
+
+  do i = 1, ordn
+    num = 1.d0
+    den = 1.d0
+    do j = 1, ordn
+      if (j /= i) then
+        dx = xa(i) - xa(j)
+        if (dx == 0.0d0) then
+          write(*,*) 'failure in polint for point',x
+          write(*,*) 'with input points: ',xa
+          stop
+        end if
+        num = num * (x - xa(j))
+        den = den * dx
+      end if
+    end do
+    w(i) = num / den
+  end do
+
+  return
+  end subroutine polint_lagrange_weights
+!------------------------------------------------------------------------------
 !
 ! interpolation in 2 dimensions, follow yx order
 !
@@ -1314,19 +1349,26 @@ end subroutine d2dump
   end do
   call polint(x1a,ymtmp,x1,y,dy,ordn)
 #else
-  integer  :: j, k
-  real*8, dimension(ordn,ordn) :: yatmp
+  integer  :: i, j, k
+  real*8, dimension(ordn) :: w1, w2
   real*8, dimension(ordn) :: ymtmp
-  real*8 :: dy_temp
+  real*8 :: yx_sum, x_sum
 
-  do k=1,ordn
-    do j=1,ordn
-      call polint(x1a, ya(:,j,k), x1, yatmp(j,k), dy_temp, ordn)
+  call polint_lagrange_weights(x1a, x1, w1, ordn)
+  call polint_lagrange_weights(x2a, x2, w2, ordn)
+
+  do k = 1, ordn
+    yx_sum = 0.d0
+    do j = 1, ordn
+      x_sum = 0.d0
+      do i = 1, ordn
+        x_sum = x_sum + w1(i) * ya(i,j,k)
+      end do
+      yx_sum = yx_sum + w2(j) * x_sum
     end do
+    ymtmp(k) = yx_sum
   end do
-  do k=1,ordn
-    call polint(x2a, yatmp(:,k), x2, ymtmp(k), dy_temp, ordn)
-  end do
+
   call polint(x3a, ymtmp, x3, y, dy, ordn)
 #endif