diff --git a/AMSS_NCKU_source/fmisc.f90 b/AMSS_NCKU_source/fmisc.f90 index 0feed47..1b57677 100644 --- a/AMSS_NCKU_source/fmisc.f90 +++ b/AMSS_NCKU_source/fmisc.f90 @@ -1112,64 +1112,65 @@ end subroutine d2dump ! Lagrangian polynomial interpolation !------------------------------------------------------------------------------ - subroutine polint(xa,ya,x,y,dy,ordn) - + subroutine polint(xa, ya, x, y, dy, ordn) implicit none -!~~~~~~> Input Parameter: - integer,intent(in) :: ordn - real*8, dimension(ordn), intent(in) :: xa,ya + integer, intent(in) :: ordn + real*8, dimension(ordn), intent(in) :: xa, ya real*8, intent(in) :: x - real*8, intent(out) :: y,dy + real*8, intent(out) :: y, dy -!~~~~~~> Other parameter: + integer :: i, m, ns, n_m + real*8, dimension(ordn) :: c, d, ho + real*8 :: dif, dift, hp, h, den_val - integer :: m,n,ns - real*8, dimension(ordn) :: c,d,den,ho - real*8 :: dif,dift + c = ya + d = ya + ho = xa - x -!~~~~~~> + ns = 1 + dif = abs(x - xa(1)) - n=ordn - m=ordn - - c=ya - d=ya - ho=xa-x - - ns=1 - dif=abs(x-xa(1)) - do m=1,n - dift=abs(x-xa(m)) - if(dift < dif) then - ns=m - dif=dift - end if + do i = 2, ordn + dift = abs(x - xa(i)) + if (dift < dif) then + ns = i + dif = dift + end if end do - y=ya(ns) - ns=ns-1 - do m=1,n-1 - den(1:n-m)=ho(1:n-m)-ho(1+m:n) - if (any(den(1:n-m) == 0.0))then - write(*,*) 'failure in polint for point',x - write(*,*) 'with input points: ',xa - stop - endif - den(1:n-m)=(c(2:n-m+1)-d(1:n-m))/den(1:n-m) - d(1:n-m)=ho(1+m:n)*den(1:n-m) - c(1:n-m)=ho(1:n-m)*den(1:n-m) - if (2*ns < n-m) then - dy=c(ns+1) + y = ya(ns) + ns = ns - 1 + + do m = 1, ordn - 1 + n_m = ordn - m + do i = 1, n_m + hp = ho(i) + h = ho(i+m) + den_val = hp - h + + if (den_val == 0.0d0) then + write(*,*) 'failure in polint for point',x + write(*,*) 'with input points: ',xa + stop + end if + + den_val = (c(i+1) - d(i)) / den_val + + d(i) = h * den_val + c(i) = hp * den_val + end do + + if (2 * ns < n_m) then + dy = c(ns + 1) else - dy=d(ns) - ns=ns-1 + dy = d(ns) + ns = ns - 1 end if - y=y+dy + y = y + dy end do return - end subroutine polint !------------------------------------------------------------------------------ ! @@ -1177,35 +1178,37 @@ end subroutine d2dump ! !------------------------------------------------------------------------------ subroutine polin2(x1a,x2a,ya,x1,x2,y,dy,ordn) - implicit none -!~~~~~~> Input parameters: integer,intent(in) :: ordn real*8, dimension(1:ordn), intent(in) :: x1a,x2a real*8, dimension(1:ordn,1:ordn), intent(in) :: ya real*8, intent(in) :: x1,x2 real*8, intent(out) :: y,dy -!~~~~~~> Other parameters: - +#ifdef POLINT_LEGACY_ORDER integer :: i,m real*8, dimension(ordn) :: ymtmp real*8, dimension(ordn) :: yntmp m=size(x1a) - do i=1,m - yntmp=ya(i,:) call polint(x2a,yntmp,x2,ymtmp(i),dy,ordn) - end do - call polint(x1a,ymtmp,x1,y,dy,ordn) +#else + integer :: j + real*8, dimension(ordn) :: ymtmp + real*8 :: dy_temp + + do j=1,ordn + call polint(x1a, ya(:,j), x1, ymtmp(j), dy_temp, ordn) + end do + call polint(x2a, ymtmp, x2, y, dy, ordn) +#endif return - end subroutine polin2 !------------------------------------------------------------------------------ ! @@ -1213,18 +1216,15 @@ end subroutine d2dump ! !------------------------------------------------------------------------------ subroutine polin3(x1a,x2a,x3a,ya,x1,x2,x3,y,dy,ordn) - implicit none -!~~~~~~> Input parameters: integer,intent(in) :: ordn real*8, dimension(1:ordn), intent(in) :: x1a,x2a,x3a real*8, dimension(1:ordn,1:ordn,1:ordn), intent(in) :: ya real*8, intent(in) :: x1,x2,x3 real*8, intent(out) :: y,dy -!~~~~~~> Other parameters: - +#ifdef POLINT_LEGACY_ORDER integer :: i,j,m,n real*8, dimension(ordn,ordn) :: yatmp real*8, dimension(ordn) :: ymtmp @@ -1233,24 +1233,33 @@ end subroutine d2dump m=size(x1a) n=size(x2a) - do i=1,m do j=1,n - yqtmp=ya(i,j,:) call polint(x3a,yqtmp,x3,yatmp(i,j),dy,ordn) - end do - yntmp=yatmp(i,:) call polint(x2a,yntmp,x2,ymtmp(i),dy,ordn) - end do - call polint(x1a,ymtmp,x1,y,dy,ordn) +#else + integer :: j, k + real*8, dimension(ordn,ordn) :: yatmp + real*8, dimension(ordn) :: ymtmp + real*8 :: dy_temp + + do k=1,ordn + do j=1,ordn + call polint(x1a, ya(:,j,k), x1, yatmp(j,k), dy_temp, ordn) + end do + 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 return - end subroutine polin3 !-------------------------------------------------------------------------------------- ! calculate L2norm