s_bsplines_non_uniform__eval_basis_and_n_derivs Subroutine

private pure subroutine s_bsplines_non_uniform__eval_basis_and_n_derivs(self, x, n, derivs, jmin)

Evaluate value and n derivatives at x of all basis functions with support in local cell derivs[i,j] = (d/dx)^i B_j(x) for 0 <= i <= n and jmin <= j <= jmin+degree

Type Bound

sll_t_bsplines_non_uniform

Arguments

Type IntentOptional Attributes Name
class(sll_t_bsplines_non_uniform), intent(in) :: self

non-uniform B-splines

real(kind=wp), intent(in) :: x

evaluation point

integer, intent(in) :: n

number of required derivatives

real(kind=wp), intent(out) :: derivs(0:,0:)
integer, intent(out) :: jmin

index of first non-zero B-spline


Calls

proc~~s_bsplines_non_uniform__eval_basis_and_n_derivs~~CallsGraph proc~s_bsplines_non_uniform__eval_basis_and_n_derivs sll_t_bsplines_non_uniform%s_bsplines_non_uniform__eval_basis_and_n_derivs proc~f_bsplines_non_uniform__find_cell sll_t_bsplines_non_uniform%f_bsplines_non_uniform__find_cell proc~s_bsplines_non_uniform__eval_basis_and_n_derivs->proc~f_bsplines_non_uniform__find_cell sll_assert sll_assert proc~s_bsplines_non_uniform__eval_basis_and_n_derivs->sll_assert

Source Code

  SLL_PURE subroutine s_bsplines_non_uniform__eval_basis_and_n_derivs( self, x, n, derivs, jmin )
    class(sll_t_bsplines_non_uniform), intent(in   ) :: self
    real(wp)                         , intent(in   ) :: x
    integer                          , intent(in   ) :: n
    real(wp)                         , intent(  out) :: derivs(0:,0:)
    integer                          , intent(  out) :: jmin

    integer  :: icell

    integer  :: j, r
    real(wp) :: temp
    real(wp) :: saved

    integer  :: k, s1, s2, rk, pk, j1, j2
    real(wp) :: d

    ! GFortran: to allocate on stack use -fstack-arrays
    real(wp) :: left (1:self%degree)
    real(wp) :: right(1:self%degree)
    real(wp) :: ndu  (0:self%degree,0:self%degree)
    real(wp) :: a    (0:1          ,0:self%degree)

    ! Check on inputs
    SLL_ASSERT( x > self%xmin - 1.0d-14 )
    SLL_ASSERT( x < self%xmax + 1.0d-14 )
    SLL_ASSERT( n >= 0 )
    SLL_ASSERT( n <= self%degree )
    SLL_ASSERT( size(derivs,1) == 1+n           )
    SLL_ASSERT( size(derivs,2) == 1+self%degree )

    ! 1. Compute cell index 'icell' and x_offset
!    icell = f_bsplines_non_uniform__find_cell( self, x )
    icell = self % find_cell( x )
    SLL_ASSERT( icell >= 1               )
    SLL_ASSERT( icell <= self%ncells     )
    SLL_ASSERT( self%knots(icell) <= x   )
    SLL_ASSERT( x <= self%knots(icell+1) )

    ! 2. Compute index range of B-splines with support over cell 'icell'
    jmin = icell - self%offset

    ! 3. Compute nonzero basis functions and knot differences for splines
    !    up to degree (degree-1) which are needed to compute derivative
    !    Algorithm  A2.3 of NURBS book
    !
    !    21.08.2017: save inverse of knot differences to avoid unnecessary divisions
    !                [Yaman Güçlü, Edoardo Zoni]
    associate( degree => self%degree )

      ndu(0,0) = 1.0_wp
      do j = 1, degree
         left(j)  = x - self%knots(icell+1-j)
         right(j) = self%knots(icell+j) - x
         saved    = 0.0_wp
         do r = 0, j-1
            ! compute inverse of knot differences and save them into lower triangular part of ndu
            ndu(j,r) = 1.0_wp / (right(r+1) + left(j-r))
            ! compute basis functions and save them into upper triangular part of ndu
            temp     = ndu(r,j-1) * ndu(j,r)
            ndu(r,j) = saved + right(r+1) * temp
            saved    = left(j-r) * temp
         end do
         ndu(j,j) = saved
      end do
      derivs(0,:) = ndu(:,degree)

      do r = 0, degree
         s1 = 0
         s2 = 1
         a(0,0) = 1.0_wp
         do k = 1, n
            d  = 0.0_wp
            rk = r-k
            pk = degree-k
            if (r >= k) then
               a(s2,0) = a(s1,0) * ndu(pk+1,rk)
               d = a(s2,0) * ndu(rk,pk)
            end if
            if (rk > -1) then
               j1 = 1
            else
               j1 = -rk
            end if
            if (r-1 <= pk) then
               j2 = k-1
            else
               j2 = degree-r
            end if
            do j = j1, j2
               a(s2,j) = (a(s1,j) - a(s1,j-1)) * ndu(pk+1,rk+j)
               d = d + a(s2,j) * ndu(rk+j,pk)
            end do
            if (r <= pk) then
               a(s2,k) = - a(s1,k-1) * ndu(pk+1,r)
               d = d + a(s2,k) * ndu(r,pk)
            end if
            derivs(k,r) = d
            j  = s1
            s1 = s2
            s2 = j
         end do
      end do
      r = degree
      do k = 1, n
         derivs(k,:) = derivs(k,:) * r
         r = r * (degree-k)
      end do

    end associate

  end subroutine s_bsplines_non_uniform__eval_basis_and_n_derivs