! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
!   VERSION 2.2
!
!   f90 VERSION
!
!   This library contains routines for B-spline interpolation in
!   one, two, and three dimensions. Part of the routines are based
!   on the book by Carl de Boor: A practical guide to Splines (Springer,
!   New-York 1978) and have the same calling sequence and names as
!   the corresponding routines from the IMSL library. For documen-
!   tation see the additional files. NOTE: The results in the demo
!   routines may vary slightly on different architectures.
!
!   by W. Schadow 12/04/99
!   last changed by W. Schadow 07/28/2000
!
!
!   Wolfgang Schadow
!   TRIUMF
!   4004 Wesbrook Mall
!   Vancouver, B.C. V6T 2A3
!   Canada
!
!   email: schadow@triumf.ca  or  schadow@physik.uni-bonn.de
!
!   www  : http://www.triumf.ca/people/schadow
!
!
!
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
!   Copyright (C) 2000 Wolfgang Schadow
!
!   This library is free software; you can redistribute it and/or
!   modify it under the terms of the GNU Library General Public
!   License as published by the Free Software Foundation; either
!   version 2 of the License, or (at your option) any later version.
!
!   This library is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!   Library General Public License for more details.
!
!   You should have received a copy of the GNU Library General Public
!   License along with this library; if not, write to the
!   Free Software Foundation, Inc., 59 Temple Place - Suite 330,
!   Boston, MA  02111-1307, USA.
!
!
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

module bspline

!
!  ------------------------------------------------------------------
!
!
!   The following routines are included:
!
!            dbsnak
!
!            dbsint
!            dbsval
!            dbsder
!            dbs1gd
!
!            dbs2in
!            dbs2dr
!            dbs2vl
!            dbs2gd
!
!            dbs3in
!            dbs3vl
!            dbs3dr
!            dbs3gd
!
!  ------------------------------------------------------------------
!

  private

  public dbsnak
  public dbsint, dbsval, dbsder, dbs1gd
  public dbs2in, dbs2dr, dbs2vl, dbs2gd
  public dbs3in, dbs3vl, dbs3dr, dbs3gd

contains

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbsnak(nx,xvec,kxord,xknot)

!
!  Compute the `not-a-knot' spline knot sequence.
!  (see de Boor p. 167)
!
!   nx     - number of data points.  (input)
!   xvec   - array of length ndata containing the location of the
!            data points.  (input)
!   kxord  - order of the spline.  (input)
!   xknot  - array of length ndata+korder containing the knot
!            sequence.  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in) :: nx, kxord

    real(kind=real64), dimension(nx), intent(in)        :: xvec
    real(kind=real64), dimension(nx+kxord), intent(out) :: xknot

    real(kind=real64) :: eps
    integer        :: ix
    logical        :: first = .true.

    save first,eps

    if (first) then
       first=.false.
       eps = epsilon(1.0_real64)
!       write(6,*) "subroutine dbsnak: "
!       write(6,*) "eps = ",eps
    endif

    if((kxord .lt. 0) .or. (kxord .gt. nx)) then
       write(6,*) "subroutine dbsnak: error"
       write(6,*) "0 <= kxord <= nx is required."
       write(6,*) "kxord = ", kxord, " and nx = ", nx,  " is given."
       stop
    endif

    do ix = 1, kxord
       xknot(ix) = xvec(1)
    end do

    if(mod(kxord,2) .eq. 0) then
       do ix = kxord+1, nx
          xknot(ix) = xvec(ix-kxord/2)
       end do
    else
       do ix = kxord+1, nx
          xknot(ix) = 0.5_real64 * (xvec(ix-kxord/2) + xvec(ix-kxord/2-1))
       end do
    endif

    do ix = nx+1, nx+kxord
       xknot(ix) = xvec(nx) * (1.0_real64 + eps)
    end do

  end subroutine dbsnak

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbsint(nx,xvec,xdata,kx,xknot,bcoef)

!
!  Computes the spline interpolant, returning the B-spline coefficients.
!  (see de Boor p. 204)
!
!   nx     - number of data points.  (input)
!   xvec   - array of length nx containing the data point
!            abscissas.  (input)
!   xdata  - array of length ndata containing the data point
!            ordinates.  (input)
!   kx     - order of the spline.  (input)
!            korder must be less than or equal to ndata.
!   xknot  - array of length nx+kx containing the knot
!            sequence.  (input)
!            xknot must be nondecreasing.
!   bscoef - array of length ndata containing the B-spline
!            coefficients.  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                          :: nx, kx
    real(kind=real64), dimension(nx), intent(in)    :: xdata, xvec
    real(kind=real64), dimension(nx+kx), intent(in) :: xknot
    real(kind=real64), dimension(nx), intent(out)   :: bcoef

    integer                                :: nxp1, kxm1, kpkm2, leftx, lenq
    integer                                :: ix, ik,ilp1mx, jj, iflag
    real(kind=real64)                         :: xveci
    real(kind=real64), dimension((2*kx-1)*nx) :: work

    nxp1  = nx + 1
    kxm1  = kx - 1
    kpkm2 = 2 * kxm1
    leftx = kx
    lenq  = nx * (kx + kxm1)

    do ix = 1, lenq
       work(ix) = 0.0_real64
    end do

    do  ix = 1, nx
       xveci  = xvec(ix)
       ilp1mx = min0(ix+kx,nxp1)
       leftx   = max0(leftx,ix)
       if (xveci .lt. xknot(leftx)) goto 998
30     if (xveci .lt. xknot(leftx+1)) go to 40
       leftx = leftx + 1
       if (leftx .lt. ilp1mx) go to 30
       leftx = leftx - 1
       if (xveci .gt. xknot(leftx+1)) goto 998
40     call bsplvb (xknot,nx+kx,kx,1,xveci,leftx,bcoef)
       jj = ix - leftx + 1 + (leftx - kx) * (kx + kxm1)
       do ik = 1, kx
          jj       = jj + kpkm2
          work(jj) = bcoef(ik)
       end do
    end do

    call banfac(work,kx+kxm1,nx,kxm1,kxm1,iflag)

    if (iflag .ne. 1) then
       write(6,*) "subroutine dbsint: error"
       write(6,*) "no solution of linear equation system !!!"
       stop
    end if

    do ix = 1, nx
       bcoef(ix) = xdata(ix)
    end do

    call banslv(work,kx+kxm1,nx,kxm1,kxm1,bcoef)

    return

998 write(6,*) "subroutine dbsint:"
    write(6,*) "xknot(ix) <= xknot(ix+1) required."
    write(6,*) ix,xknot(ix),xknot(ix+1)

    stop

  end subroutine dbsint

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbsval(x,kx,xknot,nx,bcoef)

!
!  Evaluates a spline, given its B-spline representation.
!
!   x      - point at which the spline is to be evaluated.  (input)
!   kx     - order of the spline.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence.  (input)
!            xknot must be nondecreasing.
!   nx     - number of B-spline coefficients.  (input)
!   bcoef  - array of length nx containing the B-spline
!            coefficients.  (input)
!   dbsval - value of the spline at x.  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                          :: nx, kx
    real(kind=real64)                               :: dbsval
    real(kind=real64)                               :: x
    real(kind=real64), dimension(nx+kx), intent(in) :: xknot
    real(kind=real64), dimension(nx), intent(in)    :: bcoef

    integer                       :: il, ik, ix, leftx
    real(kind=real64)                :: save1, save2
    real(kind=real64), dimension(kx) :: work, dl, dr

!
!     check if xknot(i) <= xknot(i+1) and calculation of i so that
!     xknot(i) <= x < xknot(i+1)
!

    leftx = 0

    do ix = 1,nx+kx-1
       if (xknot(ix) .gt. xknot(ix+1)) then
          write(6,*) "subroutine dbsval:"
          write(6,*) "xknot(ix) <= xknot(ix+1) required."
          write(6,*) ix,xknot(ix),xknot(ix+1)
          stop
       endif
       if((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) leftx = ix
    end do

    if(leftx .eq. 0) then
       write(6,*) "subroutine dbsval:"
       write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
       write(6,*) "x = ", x
       stop
    endif

    do ik = 1, kx-1
       work(ik) = bcoef(leftx+ik-kx)
       dl(ik)   = x - xknot(leftx+ik-kx)
       dr(ik)   = xknot(leftx+ik) - x
    end do

    work(kx)  = bcoef(leftx)
    dl(kx)    = x - xknot(leftx)

    do ik = 1, kx-1
       save2 = work(ik)
       do il = ik+1, kx
          save1 = work(il)
          work(il) = (dl(il) * work(il) + dr(il-ik) * save2)                  &
               &           / (dl(il) + dr(il - ik))
          save2 = save1
       end do
    end do

    dbsval = work(kx)

  end function dbsval

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbsder(iderx,x,kx,xknot,nx,bcoef)

!
!  Evaluates the derivative of a spline, given its B-spline representation.
!
!
!   iderx  - order of the derivative to be evaluated.  (input)
!            in particular, iderx = 0 returns the value of the
!            spline.
!   x      - point at which the spline is to be evaluated.  (input)
!   kx     - order of the spline.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence.  (input)
!            xknot must be nondecreasing.
!   nx     - number of B-spline coefficients.  (input)
!   bcoef  - array of length nx containing the B-spline
!            coefficients.  (input)
!   dbsder - value of the iderx-th derivative of the spline at x.
!            (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                          :: iderx, kx, nx
    real(kind=real64)                               :: dbsder
    real(kind=real64), intent(in)                   :: x
    real(kind=real64), dimension(nx+kx), intent(in) :: xknot
    real(kind=real64), dimension(nx), intent(in)    :: bcoef

    integer                       :: ix, ik, il, leftx
    real(kind=real64)                :: save, save1, save2, y, sum, dik
    real(kind=real64), dimension(kx) :: work, dl, dr,bsp

!
!     check if xknot(i) <= xknot(i+1) and calculation of i so that
!     xknot(i) <= x < xknot(i+1)
!

    leftx = 0
    do ix = 1,nx+kx-1
       if (xknot(ix) .gt. xknot(ix+1)) then
          write(6,*) "subroutine dbsder:"
          write(6,*) "xknot(ix) <= xknot(ix+1) required."
          stop
       endif
       if ((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) leftx = ix
    end do

    if (leftx .eq. 0) then
       write(6,*) "subroutine dbsder:"
       write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
       write(6,*) "xknot(1)     = ", xknot(1)
       write(6,*) "xknot(nx+kx) = ", xknot(nx+kx)
       write(6,*) "         x   = ", x
       stop
    endif

    if (iderx .eq. 0) then

       do ik = 1,kx-1
          work(ik) = bcoef(leftx+ik-kx)
          dl(ik)   = x - xknot(leftx+ik-kx)
          dr(ik)   = xknot(leftx+ik) - x
       end do

       work(kx)  = bcoef(leftx)
       dl(kx)    = x - xknot(leftx)

       do ik = 1,kx-1
          save2 = work(ik)
          do il = ik+1,kx
             save1 = work(il)
             work(il) = (dl(il) * work(il) + dr(il-ik) * save2)               &
                  &              / (dl(il) + dr(il - ik))
             save2 = save1
          end do
       end do

       dbsder = work(kx)

    elseif ((iderx .ge. 1) .and. (iderx .lt. kx)) then

       bsp(1) = 1.0_real64
       do ik = 1,kx-iderx-1
          dr(ik) = xknot(leftx+ik) - x
          dl(ik) = x - xknot(leftx+1-ik)
          save   = bsp(1)
          bsp(1) = 0.0_real64
          do il = 1, ik
             y         = save / (dr(il) + dl(ik+1-il))
             bsp(il)   = bsp(il) + dr(il) * y
             save      = bsp(il+1)
             bsp(il+1) = dl(ik+1-il) * y
          end do
       end do

       do ik = 1, kx
          work(ik) = bcoef(leftx+ik-kx)
          dr(ik)   = xknot(leftx+ik) - x
          dl(ik)   = x - xknot(leftx+ik-kx)
       end do

       do ik = 1, iderx
          dik   = Real(kx - ik,real64)
          save2 = work(ik)
          do il = ik+1, kx
             save1    = work(il)
             work(il) = dik * (work(il) - save2) /(dl(il) + dr(il-ik))
             save2    = save1
          end do
       end do

       sum = 0.0_real64

       do ix = 1, kx-iderx
          sum = sum + bsp(ix) * work(iderx+ix)
       end do

       dbsder = sum

    else
       dbsder = 0.0_real64
    endif

  end function dbsder

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbs1gd(iderx,nxvec,xvec,kx,xknot,nx,bcoef,val)

!
!  Evaluates the derivative of a spline on a grid, given its B-spline
!  representation.
!
!   iderx  - order of the derivative to be evaluated.  (input)
!            in particular, iderx = 0 returns the value of the
!            spline.
!   nxvec  - length of vector xvec.  (input)
!   xvec   - array of length nxvec containing the points at which the
!            spline is to be evaluated.  (input)
!            xvec should be strictly increasing.
!   kx     - order of the spline.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence.  (input)
!            xknot must be nondecreasing.
!   nx     - number of B-spline coefficients.  (input)
!   bcoef  - array of length nx containing the B-spline
!            coefficients.  (input)
!   val    - array of length nxvec containing the values of the
!            iderx-th derivative of the spline at the points in
!            xvec.  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                           :: iderx, nxvec, kx, nx
    real(kind=real64), dimension(nxvec), intent(in)  :: xvec
    real(kind=real64), dimension(nx), intent(in)     :: bcoef
    real(kind=real64), dimension(nx+kx), intent(in)  :: xknot
    real(kind=real64), dimension(nxvec), intent(out) :: val

    integer                             :: i, il, ik, ix
    integer, dimension(nxvec)           :: leftx
    real(kind=real64)                      :: dik
    real(kind=real64), dimension(nxvec,kx) :: dl, dr, biatx, work
    real(kind=real64), dimension(nxvec)    :: save1, save2, term

    logical :: same, next

    leftx(1) = 0

    call huntn(xknot,nx+kx,kx,xvec(1),leftx(1))

    do ix = 2, nxvec
       leftx(ix) = leftx(ix-1)
       same = (xknot(leftx(ix)) .le. xvec(ix))                                &
            &        .and. (xvec(ix) .le. xknot(leftx(ix)+1))
       if(.not. same ) then
          leftx(ix) = leftx(ix) + 1
          next      = (xknot(leftx(ix)) .le. xvec(ix))                        &
               &           .and. (xvec(ix) .le. xknot(leftx(ix)+1))
          if (.not. next)                                                     &
               &           call huntn(xknot,nx+kx,kx,xvec(ix),leftx(ix))
       endif
    end do

    do ix = 1, nx+kx-1
       if (xknot(ix) .gt. xknot(ix+1)) then
          write(6,*) "subroutine dbs1gd:"
          write(6,*) "xknot(ix) <= xknot(ix+1) required."
          write(6,*) ix, xknot(ix), xknot(ix+1)
          write(6,*)
          write(6,*) xknot
          stop
       endif
    end do

    do ix = 1, nxvec
       if ((xvec(ix).lt.xknot(1)).or.(xvec(ix).gt.xknot(nx+kx))) then
          write(6,*) "subroutine dbs1gd:"
          write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
          write(6,*) "x = ", xvec(ix)
          stop
       endif
    end do

    if (iderx .eq. 0) then

       do ix = 1,nxvec
          biatx(ix,1) = 1._real64
          val(ix)     = 0._real64
       end do

       do ik = 1, kx-1
          do ix = 1, nxvec
             dr(ix,ik) = xknot(leftx(ix)+ik) - xvec(ix)
             dl(ix,ik) = xvec(ix) - xknot(leftx(ix)+1-ik)
             save1(ix) = 0._real64
          end do

          do il = 1, ik
             do ix = 1,nxvec
                term(ix)     = biatx(ix,il)                                   &
                     &                 / (dr(ix,il) + dl(ix,ik+1-il))
                biatx(ix,il) = save1(ix) + dr(ix,il) * term(ix)
                save1(ix)    = dl(ix,ik+1-il) * term(ix)
             end do
          end do

          do ix = 1, nxvec
             biatx(ix,ik+1) = save1(ix)
          end do
       end do

       do ik = 1, kx
          do ix = 1, nxvec
             val(ix) = val(ix) + biatx(ix,ik) * bcoef(leftx(ix)-kx+ik)
          end do
       end do

    elseif ((iderx .ge. 1) .and. (iderx .lt. kx)) then

       do ix = 1, nxvec
          biatx(ix,1) = 1._real64
          val(ix)     = 0._real64
       end do

       do ik = 1, kx-iderx-1
          do ix = 1, nxvec
             dr(ix,ik)   = xknot(leftx(ix)+ik) - xvec(ix)
             dl(ix,ik)   = xvec(ix) - xknot(leftx(ix)+1-ik)
             save1(ix)    = biatx(ix,1)
             biatx(ix,1) = 0.0_real64
             do il = 1, ik
                term(ix)       = save1(ix)                                    &
                     &                 / (dr(ix,il) + dl(ix,ik+1-il))
                biatx(ix,il)   = biatx(ix,il) + dr(ix,il) * term(ix)
                save1(ix)      = biatx(ix,il+1)
                biatx(ix,il+1) = dl(ix,ik+1-il) * term(ix)
             end do
          end do
       end do

       do ik = 1, kx
          do ix = 1, nxvec
             work(ix,ik) = bcoef(leftx(ix)+ik-kx)
             dr(ix,ik)   = xknot(leftx(ix)+ik) - xvec(ix)
             dl(ix,ik)   = xvec(ix) - xknot(leftx(ix)+ik-kx)
          end do
       end do

       do ik = 1, iderx
          dik   = Real(kx - ik,real64)
          do ix = 1, nxvec
             save2(ix) = work(ix,ik)
             do il = ik+1, kx
                save1(ix)   = work(ix,il)
                work(ix,il) = dik * (work(ix,il) - save2(ix))                 &
                     &                 /(dl(ix,il) + dr(ix,il-ik))
                save2(ix)   = save1(ix)
             end do
          end do
       end do

       do i = 1, kx-iderx
          do ix = 1, nxvec
             val(ix) = val(ix) + biatx(ix,i) * work(ix,iderx+i)
          end do
       end do

    else

       do ix = 1, nxvec
          val(ix) = 0.0_real64
       end do

    endif

  end subroutine dbs1gd

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbsdca(iderx,x,kx,xknot,nx,bcoef,leftx)

!
! This routine is equivalent to the routine dbsder, but it does not
! check the parameters!!!
!
! Evaluates the derivative of a spline, given its B-spline representation.
!
!
!   iderx  - order of the derivative to be evaluated.  (input)
!            in particular, iderx = 0 returns the value of the
!            spline.
!   x      - point at which the spline is to be evaluated.  (input)
!   kx     - order of the spline.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence.  (input)
!            xknot must be nondecreasing.
!   nx     - number of B-spline coefficients.  (input)
!   bcoef  - array of length nx containing the B-spline
!            coefficients.  (input)
!   leftx  - number of the intervall of xknot that includes x
!   dbsdca - value of the ideriv-th derivative of the spline at x.
!            (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                          :: iderx, kx, nx
    real(kind=real64)                               :: dbsdca
    real(kind=real64), intent(in)                   :: x
    real(kind=real64), dimension(nx+kx), intent(in) :: xknot
    real(kind=real64), dimension(nx), intent(in)    :: bcoef

    integer                       :: i, ik, il, leftx
    real(kind=real64)                :: save, save1, save2, y, sum, dik
    real(kind=real64), dimension(kx) :: work, dl, dr,bsp

    if (iderx .eq. 0) then

       do ik = 1, kx-1
          work(ik) = bcoef(leftx+ik-kx)
          dl(ik)   = x - xknot(leftx+ik-kx)
          dr(ik)   = xknot(leftx+ik) - x
       end do

       work(kx)  = bcoef(leftx)
       dl(kx)    = x - xknot(leftx)

       do ik = 1, kx-1
          save2 = work(ik)
          do il = ik+1, kx
             save1 = work(il)
             work(il) = (dl(il) * work(il) + dr(il-ik) * save2)               &
                  &              / (dl(il) + dr(il - ik))
             save2 = save1
          end do
       end do

       dbsdca = work(kx)

    elseif ((iderx .ge. 1) .and. (iderx .lt. kx)) then
       bsp(1) = 1.0_real64
       do ik = 1,kx-iderx-1
          dr(ik) = xknot(leftx+ik) - x
          dl(ik) = x - xknot(leftx+1-ik)
          save   = bsp(1)
          bsp(1) = 0.0_real64
          do il = 1, ik
             y         = save / (dr(il) + dl(ik+1-il))
             bsp(il)   = bsp(il) + dr(il) * y
             save      = bsp(il+1)
             bsp(il+1) = dl(ik+1-il) * y
          end do
       end do

       do ik = 1, kx
          work(ik) = bcoef(leftx+ik-kx)
          dr(ik)   = xknot(leftx+ik) - x
          dl(ik)   = x - xknot(leftx+ik-kx)
       end do

       do ik = 1, iderx
          dik   = Real(kx - ik,real64)
          save2 = work(ik)
          do il = ik+1, kx
             save1    = work(il)
             work(il) = dik * (work(il) - save2) /(dl(il) + dr(il-ik))
             save2    = save1
          end do
       end do

       sum = 0.0_real64

       do i = 1, kx-iderx
          sum = sum + bsp(i) * work(iderx+i)
       end do

       dbsdca = sum

    else
       dbsdca = 0.0_real64
    endif

  end function dbsdca

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbs2in(nx,xvec,ny,yvec,xydata,ldf,kx,ky,xknot,yknot,bcoef)

!
!  Computes a two-dimensional tensor-product spline interpolant,
!  returning the tensor-product B-spline coefficients.
!
!    nx     - number of data points in the x-direction.  (input)
!    xvec   - array of length nx containing the data points in
!             the x-direction.  (input)
!             xdata must be strictly increasing.
!    ny     - number of data points in the y-direction.  (input)
!    yvec   - array of length ny containing the data points in
!             the y-direction.  (input)
!             ydata must be strictly increasing.
!    xydata - array of size nx by nydata containing the values to
!             be interpolated.  (input)
!             fdata(i,j) is the value at (xdata(i),ydata(j)).
!    ldf    - the leading dimension of fdata exactly as specified in
!             the dimension statement of the calling program.
!             (input)
!    kx     - order of the spline in the x-direction.  (input)
!             kxord must be less than or equal to nxdata.
!    ky     - order of the spline in the y-direction.  (input)
!             kyord must be less than or equal to nydata.
!    xknot  - array of length nx+kx containing the knot
!             sequence in the x-direction.  (input)
!             xknot must be nondecreasing.
!    yknot  - array of length ny+ky containing the knot
!             sequence in the y-direction.  (input)
!             yknot must be nondecreasing.
!    bcoef  - array of length nx*ny containing the
!             tensor-product B-spline coefficients.  (output)
!             bscoef is treated internally as a matrix of size nxdata
!             by nydata.
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                           :: nx, ny, kx, ky, ldf

    real(kind=real64), dimension(nx), intent(in)     :: xvec
    real(kind=real64), dimension(ny), intent(in)     :: yvec
    real(kind=real64), dimension(nx+kx), intent(in)  :: xknot
    real(kind=real64), dimension(ny+ky), intent(in)  :: yknot
    real(kind=real64), dimension(ldf,*), intent(in)  :: xydata
    real(kind=real64), dimension(nx,ny), intent(out) :: bcoef

    real(kind=real64), dimension(max(nx,ny),max(nx,ny))        :: work1
    real(kind=real64), dimension(max(nx,ny))                   :: work2
    real(kind=real64), dimension(max((2*kx-1)*nx,(2*ky-1)*ny)) :: work3

    call spli2d(xvec,ldf,xydata,xknot,nx,kx,ny,work2,work3,work1)
    call spli2d(yvec,ny, work1, yknot,ny,ky,nx,work2,work3,bcoef)

  end subroutine dbs2in

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine spli2d(xyvec,ld,xydata,xyknot,n,k,m,work2,work3,bcoef)

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                         :: ld, n, k, m
    real(kind=real64), dimension(n), intent(in)    :: xyvec
    real(kind=real64), dimension(n+k), intent(in)  :: xyknot
    real(kind=real64), dimension(ld,m), intent(in) :: xydata
    real(kind=real64), dimension(m,n), intent(out) :: bcoef

    real(kind=real64), dimension(n), intent(out)         :: work2
    real(kind=real64), dimension((2*k-1)*n), intent(out) :: work3

    integer        :: np1, km1, kpkm2, left, lenq, i, iflag, ilp1mx, j, jj
    real(kind=real64) :: xyveci

    np1   = n + 1
    km1   = k - 1
    kpkm2 = 2 * km1
    left  = k
    lenq  = n * (k + km1)

    do i = 1,lenq
       work3(i) = 0.0_real64
    end do

    do i = 1, n
       xyveci  = xyvec(i)
       ilp1mx = min0(i+k,np1)
       left   = max0(left,i)
       if (xyveci .lt. xyknot(left)) go to 998
30     if (xyveci .lt. xyknot(left+1)) go to 40
       left = left + 1
       if (left .lt. ilp1mx) go to 30
       left = left - 1
       if (xyveci .gt. xyknot(left+1)) go to 998
40     call bsplvb(xyknot,n+k,k,1,xyveci,left,work2)
       jj = i - left + 1 + (left - k) * (k + km1)
       do j = 1, k
          jj        = jj + kpkm2
          work3(jj) = work2(j)
       end do
    end do

    call banfac(work3,k+km1,n,km1,km1,iflag )

    if (iflag .ne. 1) then
       write(6,*) "subroutine dbs2in: error"
       write(6,*) "no solution of linear equation system !!!"
       stop
    end if

    do j = 1, m
       do i = 1, n
          work2(i) = xydata(i,j)
       end do

       call banslv(work3,k+km1,n,km1,km1,work2)

       do i = 1, n
          bcoef(j,i) = work2(i)
       end do
    end do

    return

998 write(6,*) "subroutine db2in:"
    write(6,*) "i with knot(i) <= x/y < knot(i+1) required."
    write(6,*) "knot(1)   = ", xyknot(1)
    write(6,*) "knot(n+k) = ", xyknot(n+k)
    write(6,*) "      x/y = ", xyveci

    stop

  end subroutine spli2d

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbs2vl(x,y,kx,ky,xknot,yknot,nx,ny,bcoef)

!
!  evaluates a two-dimensional tensor-product spline, given its
!  tensor-product B-spline representation.    use numeric
!
!   x      - x-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   y      - y-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   kx     - order of the spline in the x-direction.  (input)
!   ky     - order of the spline in the y-direction.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence in the x-direction.  (input)
!            xknot must be nondecreasing.
!   yknot  - array of length ny+ky containing the knot
!            sequence in the y-direction.  (input)
!            yknot must be nondecreasing.
!   nx     - number of B-spline coefficients in the x-direction.
!            (input)
!   ny     - number of B-spline coefficients in the y-direction.
!            (input)
!   bcoef  - array of length nx*ny containing the
!            tensor-product B-spline coefficients.  (input)
!            bscoef is treated internally as a matrix of size nx
!            by ny.
!   dbs2vl - value of the spline at (x,y).  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                          :: nx, ny, kx, ky
    real(kind=real64), intent(in)                   :: x, y
    real(kind=real64), dimension(nx+kx), intent(in) :: xknot
    real(kind=real64), dimension(ny+ky), intent(in) :: yknot
    real(kind=real64), dimension(nx,ny), intent(in) :: bcoef
    real(kind=real64)                               :: dbs2vl

    integer                       :: ix, iy, iky, leftx, lefty
    real(kind=real64), dimension(ky) :: work

!
!     check if knot(i) <= knot(i+1) and calculation of i so that
!     knot(i) <= x < knot(i+1)
!

    leftx = 0

    do ix = 1, nx+kx-1
       if (xknot(ix) .gt. xknot(ix+1)) then
          write(6,*) "subroutine dbs2vl:"
          write(6,*) "xknot(ix) <= xknot(ix+1) required."
          write(6,*) ix, xknot(ix), xknot(ix+1)
          write(6,*)
          write(6,*) xknot
          stop
       endif
       if((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) leftx = ix
    end do

    if(leftx .eq. 0) then
       write(6,*) "subroutine dbs2vl:"
       write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
       write(6,*) "x = ", x
       write(6,*)
       write(6,*) xknot
       stop
    endif

    lefty = 0

    do iy = 1, ny+ky-1
       if (yknot(iy) .gt. yknot(iy+1)) then
          write(6,*) "subroutine dbs2vl:"
          write(6,*) "yknot(iy) <= yknot(iy+1) required."
          write(6,*) iy, yknot(iy), yknot(iy+1)
          stop
       endif
       if((yknot(iy) .le. y) .and. (y .lt. yknot(iy+1))) lefty = iy
    end do

    if(lefty .eq. 0) then
       write(6,*) "subroutine dbs2vl:"
       write(6,*) "iy with yknot(iy) <= y < yknot(iy+1) required."
       write(6,*) "yknot(iy)   = ", yknot(iy)
       write(6,*) "  y         = ", y
       write(6,*) "yknot(iy+1) = ", yknot(iy+1)
       stop
    endif

    do iky = 1, ky
       work(iky) = dbsdca(0,x,kx,xknot,nx,bcoef(1,lefty-ky+iky),leftx)
    end do

    dbs2vl = dbsval(y,ky,yknot(lefty-ky+1),ky,work)

  end function dbs2vl

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbs2dr(iderx,idery,x,y,kx,ky,xknot,yknot,nx,ny,bcoef)

!
!  Evaluates the derivative of a two-dimensional tensor-product spline,
!  given its tensor-product B-spline representation.
!
!   iderx  - order of the derivative in the x-direction.  (input)
!   idery  - order of the derivative in the y-direction.  (input)
!   x      - x-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   y      - y-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   kx     - order of the spline in the x-direction.  (input)
!   ky     - order of the spline in the y-direction.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence in the x-direction.  (input)
!            xknot must be nondecreasing.
!   yknot  - array of length ny+ky containing the knot
!            sequence in the y-direction.  (input)
!            yknot must be nondecreasing.
!   nx     - number of B-spline coefficients in the x-direction.
!            (input)
!   ny     - number of B-spline coefficients in the y-direction.
!            (input)
!   bcoef  - array of length nx*ny containing the
!            tensor-product B-spline coefficients.  (input)
!            bscoef is treated internally as a matrix of size nx
!            by ny.
!   dbs2dr  - value of the (iderx,idery) derivative of the spline at
!            (x,y).  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                          :: iderx, idery
    integer, intent(in)                          :: kx, nx, ky, ny
    real(kind=real64)                               :: dbs2dr
    real(kind=real64), intent(in)                   :: x, y
    real(kind=real64), dimension(nx+kx), intent(in) :: xknot
    real(kind=real64), dimension(ny+ky), intent(in) :: yknot
    real(kind=real64), dimension(nx,ny), intent(in) :: bcoef

    integer                       :: ix, iy, iky, nintx, ninty
    real(kind=real64), dimension(ky) :: work

!
!     check if knot(i) <= knot(i+1) and calculation of i so that
!     knot(i) <= x < knot(i+1)
!

    nintx = 0

    do ix = 1, nx+kx-1
       if (xknot(ix) .gt. xknot(ix+1)) then
          write(6,*) "subroutine dbs2dr:"
          write(6,*) "xknot(ix) <= xknot(ix+1) required."
          write(6,*) ix, xknot(ix), xknot(ix+1)
          stop
       endif
       if((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) nintx = ix
    end do

    if(nintx .eq. 0) then
       write(6,*) "subroutine dbs2dr:"
       write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
       write(6,*) "x = ", x
       stop
    endif

    ninty = 0

    do iy = 1, ny+ky-1
       if (yknot(iy) .gt. yknot(iy+1)) then
          write(6,*) "subroutine dbs2dr:"
          write(6,*) "yknot(iy) <= yknot(iy+1) required."
          write(6,*) iy, yknot(iy), yknot(iy+1)
          stop
       endif
       if ((yknot(iy) .le. y) .and. (y .lt. yknot(iy+1))) ninty = iy
    end do

    if(ninty .eq. 0) then
       write(6,*) "subroutine dbs2dr:"
       write(6,*) "iy with yknot(iy) <= y < yknot(iy+1) required."
       write(6,*) "y = ", y
       stop
    endif

    do iky = 1, ky
       work(iky) =  dbsdca(iderx,x,kx,xknot,nx,bcoef(1,ninty-ky+iky),nintx)
    end do

    dbs2dr = dbsder(idery,y,ky,yknot(ninty-ky+1),ky,work)

  end function dbs2dr

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbs2gd(iderx,idery,nxvec,xvec,nyvec,yvec,kx,ky,xknot,yknot,      &
       & nx,ny,bcoef,val,ldf)

!
!  Evaluates the derivative of a two-dimensional tensor-product spline,
!  given its tensor-product B-spline representation on a grid.
!
!   iderx   - order of the derivative in the x-direction.  (input)
!   idery   - order of the derivative in the y-direction.  (input)
!   nxvec   - number of grid points in the x-direction.  (input)
!   xvec    - array of length nx containing the x-coordinates at
!             which the spline is to be evaluated.  (input)
!             the points in xvec should be strictly increasing.
!   nyvec   - number of grid points in the y-direction.  (input)
!   yvec    - array of length ny containing the y-coordinates at
!             which the spline is to be evaluated.  (input)
!             the points in yvec should be strictly increasing.
!   kx      - order of the spline in the x-direction.  (input)
!   ky      - order of the spline in the y-direction.  (input)
!   xknot   - array of length nx+kx containing the knot
!             sequence in the x-direction.  (input)
!             xknot must be nondecreasing.
!   yknot   - array of length ny+ky containing the knot
!             sequence in the y-direction.  (input)
!             yknot must be nondecreasing.
!   nx      - number of B-spline coefficients in the x-direction.
!             (input)
!   ny      - number of B-spline coefficients in the y-direction.
!             (input)
!   bcoef   - array of length nx*ny containing the
!             tensor-product B-spline coefficients.  (input)
!             bscoef is treated internally as a matrix of size nx
!             by ny.
!   val     - value of the (iderx,idery) derivative of the spline on
!             the nx by ny grid.  (output)
!             value(i,j) contains the derivative of the spline at the
!             point (xvec(i),yvec(j)).
!   ldf     - leading dimension of value exactly as specified in the
!             dimension statement of the calling program.  (input)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                           :: iderx, idery
    integer, intent(in)                           :: nxvec, nyvec
    integer, intent(in)                           :: kx, nx, ky, ny
    integer, intent(in)                           :: ldf

    real(kind=real64), dimension(nxvec), intent(in)  :: xvec
    real(kind=real64), dimension(nyvec), intent(in)  :: yvec
    real(kind=real64), dimension(nx+kx), intent(in)  :: xknot
    real(kind=real64), dimension(ny+ky), intent(in)  :: yknot
    real(kind=real64), dimension(nx,ny), intent(in)  :: bcoef
    real(kind=real64), dimension(ldf,*), intent(out) :: val

    integer                                     :: i, ik, il, ix, iy, ikx, iky
    integer, dimension(nxvec)                   :: leftx
    integer, dimension(nyvec)                   :: lefty
    real(kind=real64), dimension(nxvec,kx)         :: dl, dr
    real(kind=real64), dimension(max(nxvec,nyvec)) :: save1
    real(kind=real64), dimension(nxvec,kx)         :: biatx
    real(kind=real64), dimension(nyvec,ky)         :: biaty
    real(kind=real64), dimension(max(nxvec,nyvec)) :: term
    real(kind=real64), dimension(ky)               :: work

    logical :: same,next

    leftx(1) = 0

    call huntn(xknot,nx+kx,kx,xvec(1),leftx(1))

    do ix = 2, nxvec
       leftx(ix) = leftx(ix-1)
       same = (xknot(leftx(ix)) .le. xvec(ix))                                &
            &        .and. (xvec(ix) .le. xknot(leftx(ix)+1))
       if(.not. same ) then
          leftx(ix) = leftx(ix) + 1
          next      = (xknot(leftx(ix)) .le. xvec(ix))                        &
               &           .and. (xvec(ix) .le. xknot(leftx(ix)+1))
          if (.not. next)                                                     &
               &           call huntn(xknot,nx+kx,kx,xvec(ix),leftx(ix))
       endif
    end do

    do i = 1, nx+kx-1
       if (xknot(i) .gt. xknot(i+1)) then
          write(6,*) "subroutine dbs2gd:"
          write(6,*) "xknot(i) <= xknot(i+1) required."
          write(6,*) i, xknot(i), xknot(i+1)
          write(6,*)
          write(6,*) xknot
          stop
       endif
    end do

    do i = 1, nxvec
       if ((xvec(i).lt.xknot(1)).or.(xvec(i).gt.xknot(nx+kx))) then
          write(6,*) "subroutine dbs2gd:"
          write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
          write(6,*) "x = ", xvec(i)
          stop
       endif
    end do

    lefty(1) = 0

    call huntn(yknot,ny+ky,ky,yvec(1),lefty(1))

    do iy = 2, nyvec
       lefty(iy) = lefty(iy-1)
       same = (yknot(lefty(iy)) .le. yvec(iy))                                &
            &        .and. (yvec(iy) .le. yknot(lefty(iy)+1))
       if(.not. same ) then
          lefty(iy) = lefty(iy) + 1
          next      = (yknot(lefty(iy)) .le. yvec(iy))                        &
               &           .and. (yvec(iy) .le. yknot(lefty(iy)+1))
          if (.not. next) call huntn(yknot,ny+ky,ky,yvec(iy),lefty(iy))
       endif
    end do

    do i = 1, ny+ky-1
       if (yknot(i) .gt. yknot(i+1)) then
          write(6,*) "subroutine dbs2gd:"
          write(6,*) "yknot(i) <= yknot(i+1) required."
          write(6,*) i, yknot(i), yknot(i+1)
          write(6,*)
          write(6,*) yknot
          stop
       endif
    end do

    do i = 1, nyvec
       if ((yvec(i).lt.yknot(1)).or.(yvec(i).gt.yknot(ny+ky))) then
          write(6,*) "subroutine dbs2gd:"
          write(6,*) "iy with yknot(iy) <= y < yknot(iy+1) required."
          write(6,*) "y = ", yvec(i)
          stop
       endif
    end do

    if ((iderx .eq. 0) .and. (idery .eq. 0)) then

       do ix = 1,nxvec
          biatx(ix,1) = 1._real64
       end do

       do ik = 1, kx-1
          do ix = 1,nxvec
             dr(ix,ik) = xknot(leftx(ix)+ik) - xvec(ix)
             dl(ix,ik) = xvec(ix) - xknot(leftx(ix)+1-ik)
             save1(ix) = 0._real64
          end do

          do il = 1,ik
             do ix = 1,nxvec
                term(ix)     = biatx(ix,il)                                   &
                     &                 / (dr(ix,il) + dl(ix,ik+1-il))
                biatx(ix,il) = save1(ix) + dr(ix,il) * term(ix)
                save1(ix)    = dl(ix,ik+1-il) * term(ix)
             end do
          end do

          do ix = 1, nxvec
             biatx(ix,ik+1) = save1(ix)
          end do
       end do

       do iy = 1, nyvec
          biaty(iy,1) = 1._real64
       end do

       do ik = 1, ky-1
          do iy = 1, nyvec
             dr(iy,ik) = yknot(lefty(iy)+ik) - yvec(iy)
             dl(iy,ik) = yvec(iy) - yknot(lefty(iy)+1-ik)
             save1(iy) = 0._real64
          end do

          do il = 1, ik
             do iy = 1,nyvec
                term(iy)     = biaty(iy,il)                                   &
                     &                 / (dr(iy,il) + dl(iy,ik+1-il))
                biaty(iy,il) = save1(iy) + dr(iy,il) * term(iy)
                save1(iy)    = dl(iy,ik+1-il) * term(iy)
             end do
          end do

          do iy = 1, nyvec
             biaty(iy,ik+1) = save1(iy)
          end do
       end do

       do iy = 1, nyvec
          do ix = 1, nxvec
             val(ix,iy) = 0.0_real64
          end do
       end do

       do iky = 1, ky
          do ikx = 1, kx
             do iy = 1, nyvec
                do ix = 1, nxvec
                   val(ix,iy) = val(ix,iy)                                    &
                        & + biatx(ix,ikx) * biaty(iy,iky)                     &
                        & * bcoef(leftx(ix)-kx+ikx,lefty(iy)-ky+iky)
                end do
             end do
          end do
       end do

    elseif (((iderx .ge. 1) .or. (idery .ge. 1))                              &
         &  .and. ( (iderx .lt. kx) .and. (idery .lt. ky))) then

       do iy = 1, nyvec
          do ix = 1, nxvec
             do iky = 1, ky
                work(iky) = dbsdca(iderx,xvec(ix),kx,xknot,nx,                &
                     &             bcoef(1,lefty(iy)-ky+iky),leftx(ix))
             end do
             val(ix,iy) = dbsder(idery,yvec(iy),ky,                           &
                  &              yknot(lefty(iy)-ky+1),ky,work)
          end do
       end do

    else

       do iy = 1, nyvec
          do ix = 1, nxvec
             val(ix,iy) = 0.0_real64
          end do
       end do

    endif

  end subroutine dbs2gd

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbs3in(nx,xvec,ny,yvec,nz,zvec,xyzdata,ldf,mdf,kx,ky,kz,         &
       & xknot,yknot,zknot,bcoef)

!
!  Computes a three-dimensional tensor-product spline interpolant,
!  returning the tensor-product B-spline coefficients.
!
!   nx      - number of data points in the x-direction.  (input)
!   xvec    - array of length nxdata containing the data points in
!             the x-direction.  (input)
!             xdata must be increasing.
!   ny      - number of data points in the y-direction.  (input)
!   yvec    - array of length nydata containing the data points in
!             the y-direction.  (input)
!             ydata must be increasing.
!   nz      - number of data points in the z-direction.  (input)
!   zvec    - array of length nzdata containing the data points in
!             the z-direction.  (input)
!             zdata must be increasing.
!   xyzdata - array of size nx by ny by nz containing the
!             values to be interpolated.  (input)
!             xyzdata(i,j,k) contains the value at
!             (xvec(i),yvec(j),zvec(k)).
!   ldf     - leading dimension of fdata exactly as specified in the
!             dimension statement of the calling program.  (input)
!   mdf     - middle dimension of fdata exactly as specified in the
!             dimension statement of the calling program.  (input)
!   kx      - order of the spline in the x-direction.  (input)
!             kxord must be less than or equal to nxdata.
!   ky      - order of the spline in the y-direction.  (input)
!             kyord must be less than or equal to nydata.
!   kz      - order of the spline in the z-direction.  (input)
!             kzord must be less than or equal to nzdata.
!   xknot   - array of length nx+kx containing the knot
!             sequence in the x-direction.  (input)
!             xknot must be nondecreasing.
!   yknot   - array of length ny+ky containing the knot
!             sequence in the y-direction.  (input)
!             yknot must be nondecreasing.
!   zknot   - array of length nz+kz containing the knot
!             sequence in the z-direction.  (input)
!             zknot must be nondecreasing.
!   bcoef   - array of length nx*ny*nz containing the
!             tensor-product B-spline coefficients.  (output)
!             bscoef is treated internally as a matrix of size nx
!             by ny by nz.
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in) :: nx, ny, nz, kx, ky, kz
    integer, intent(in) :: ldf, mdf

    real(kind=real64), dimension(nx), intent(in)         :: xvec
    real(kind=real64), dimension(ny), intent(in)         :: yvec
    real(kind=real64), dimension(nz), intent(in)         :: zvec
    real(kind=real64), dimension(nx+kx), intent(in)      :: xknot
    real(kind=real64), dimension(ny+ky), intent(in)      :: yknot
    real(kind=real64), dimension(nz+kz), intent(in)      :: zknot
    real(kind=real64), dimension(ldf,mdf,nz), intent(in) :: xyzdata
    real(kind=real64), dimension(nx,ny,nz), intent(out)  :: bcoef

    integer                                :: iz
    real(kind=real64), dimension(nx,ny,nz)    :: work1
    real(kind=real64), dimension(nz)          :: work2
    real(kind=real64), dimension((2*kz-1)*nz) :: work3

    call spli3d(zvec,ldf,mdf,xyzdata,zknot,nz,kz,nx,ny,work2,work3,work1,     &
         &     nx,ny,nz)

    do iz = 1, nz
       call dbs2in(nx,xvec,ny,yvec,work1(1,1,iz),nx,kx,ky,xknot,yknot,        &
            &        bcoef(1,1,iz))
    end do

  end subroutine dbs3in

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine spli3d(xyzvec,ldf,mdf,xyzdata,xyzknot,n,k,m,l,work2,work3,       &
       & bcoef,nx,ny,nz)

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                               :: ldf, mdf, n, k, m, l
    integer, intent(in)                               :: nx, ny, nz
    real(kind=real64), dimension(n), intent(in)          :: xyzvec
    real(kind=real64), dimension(n+k), intent(in)        :: xyzknot
    real(kind=real64), dimension(ldf,mdf,*), intent(in)  :: xyzdata
    real(kind=real64), dimension(nx,ny,nz), intent(out)  :: bcoef
    real(kind=real64), dimension(n), intent(out)         :: work2
    real(kind=real64), dimension((2*k-1)*n), intent(out) :: work3

    integer        :: np1, km1, kpkm2, left, lenq, i, ilp1mx, j, jj, iflag, in
    real(kind=real64) :: xyzveci

    np1   = n + 1
    km1   = k - 1
    kpkm2 = 2 * km1
    left  = k
    lenq  = n * (k + km1)

    do i = 1, lenq
       work3(i) = 0._real64
    end do

    do i = 1, n
       xyzveci = xyzvec(i)
       ilp1mx  = min0(i+k,np1)
       left    = max0(left,i)
       if (xyzveci .lt. xyzknot(left)) go to 998
30     if (xyzveci .lt. xyzknot(left+1)) go to 40
       left = left + 1
       if (left .lt. ilp1mx) go to 30
       left = left - 1
       if (xyzveci .gt. xyzknot(left+1)) go to 998
40     call bsplvb(xyzknot,n+k,k,1,xyzveci,left,work2)
       jj = i - left + 1 + (left - k) * (k + km1)
       do j = 1, k
          jj    = jj + kpkm2
          work3(jj) = work2(j)
       end do
    end do

    call banfac(work3,k+km1,n,km1,km1,iflag)

    if (iflag .ne. 1) then
       write(6,*) "subroutine dbs3in: error"
       write(6,*) "no solution of linear equation system !!!"
       stop
    end if

    do j = 1, l
       do i = 1, m
          do in = 1, n
             work2(in) = xyzdata(i,j,in)
          end do

          call banslv(work3,k+km1,n,km1,km1,work2)

          do in = 1, n
             bcoef(i,j,in) = work2(in)
          end do

       end do
    end do

    return

998 write(6,*) "subroutine db3in:"
    write(6,*) "i with knot(i) <= x/y/z < knot(i+1) required."
    write(6,*) "knot(1)   = ", xyzknot(1)
    write(6,*) "knot(n+k) = ", xyzknot(n+k)
    write(6,*) "    x/y/z = ", xyzveci

    stop

  end subroutine spli3d

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbs3vl(x,y,z,kx,ky,kz,xknot,yknot,zknot,nx,ny,nz,bcoef)

!
!  Evaluates a three-dimensional tensor-product spline, given its
!  tensor-product B-spline representation.
!
!   x      - x-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   y      - y-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   z      - z-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   kx     - order of the spline in the x-direction.  (input)
!   ky     - order of the spline in the y-direction.  (input)
!   kz     - order of the spline in the z-direction.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence in the x-direction.  (input)
!            xknot must be nondecreasing.
!   yknot  - array of length ny+ky containing the knot
!            sequence in the y-direction.  (input)
!            yknot must be nondecreasing.
!   zknot  - array of length nz+kz containing the knot
!            sequence in the z-direction.  (input)
!            zknot must be nondecreasing.
!   nx     - number of B-spline coefficients in the x-direction.
!            (input)
!   ny     - number of B-spline coefficients in the y-direction.
!            (input)
!   nz     - number of B-spline coefficients in the z-direction.
!            (input)
!   bcoef  - array of length nx*ny*nz containing the
!            tensor-product B-spline coefficients.  (input)
!            bscoef is treated internally as a matrix of size nx
!            by ny by nz.
!   dbs3vl - value of the spline at (x,y,z).  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                             :: nx, ny, nz, kx, ky, kz
    real(kind=real64), intent(in)                      :: x, y, z
    real(kind=real64), dimension(nx+kx), intent(in)    :: xknot
    real(kind=real64), dimension(ny+ky), intent(in)    :: yknot
    real(kind=real64), dimension(nz+kz), intent(in)    :: zknot
    real(kind=real64), dimension(nx,ny,nz), intent(in) :: bcoef
    real(kind=real64)                                  :: dbs3vl

    integer                       :: iz, nintz
    real(kind=real64), dimension(kz) :: work

!
!     check if knot(i) <= knot(i+1) and calculation of i so that
!     knot(i) <= x < knot(i+1)
!

    nintz = 0

    do iz = 1, nz+kz-1
       if (zknot(iz) .gt. zknot(iz + 1)) then
          write(6,*) "subroutine dbs3vl:"
          write(6,*) "zknot(iz) <= zknot(iz+1) required."
          write(6,*) iz, zknot(iz), zknot(iz+1)
          stop
       endif
       if((zknot(iz) .le. z) .and. (z .lt. zknot(iz + 1))) nintz = iz
    end do

    if(nintz .eq. 0) then
       write(6,*) "subroutine dbs3vl:"
       write(6,*) "iz with zknot(iz) <= z < zknot(iz+1) required."
       write(6,*) "zknot(iz)   = ", zknot(iz)
       write(6,*) "  z         = ", z
       write(6,*) "zknot(iz+1) = ", zknot(iz+1)
       stop
    endif

    do iz = 1, kz
       work(iz) = dbs2vl(x,y,kx,ky,xknot,yknot,nx,ny,bcoef(1,1,nintz-kz+iz))
    end do

    dbs3vl = dbsval(z,kz,zknot(nintz-kz+1),kz,work)

  end function dbs3vl

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function dbs3dr(iderx,idery,iderz,x,y,z,kx,ky,kz,xknot,yknot,zknot,         &
       & nx,ny,nz,bcoef)

!
!  Evaluates the derivative of a three-dimensional tensor-product spline,
!  given its tensor-product B-spline representation.
!
!   iderx  - order of the x-derivative.  (input)
!   idery  - order of the y-derivative.  (input)
!   iderz  - order of the z-derivative.  (input)
!   x      - x-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   y      - y-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   z      - z-coordinate of the point at which the spline is to be
!            evaluated.  (input)
!   kx     - order of the spline in the x-direction.  (input)
!   ky     - order of the spline in the y-direction.  (input)
!   kz     - order of the spline in the z-direction.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence in the x-direction.  (input)
!            xknot must be nondecreasing.
!   yknot  - array of length ny+ky containing the knot
!            sequence in the y-direction.  (input)
!            yknot must be nondecreasing.
!   zknot  - array of length nz+kz containing the knot
!            sequence in the z-direction.  (input)
!            zknot must be nondecreasing.
!   nx     - number of B-spline coefficients in the x-direction.
!            (input)
!   ny     - number of B-spline coefficients in the y-direction.
!            (input)
!   nz     - number of B-spline coefficients in the z-direction.
!            (input)
!   bcoef  - array of length nx*ny*nz containing the
!            tensor-product B-spline coefficients.  (input)
!            bscoef is treated internally as a matrix of size nx
!            by ny by nz.
!   dbs3dr - value of the (iderx,idery,iderz) derivative of the
!            spline at (x,y,z).  (output)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                              :: iderx, idery, iderz
    integer, intent(in)                              :: nx, ny, nz, kx, ky, kz
    real(kind=real64), intent(in)                       :: x, y, z
    real(kind=real64), dimension(nx+kx), intent(in)     :: xknot
    real(kind=real64), dimension(ny+ky), intent(in)     :: yknot
    real(kind=real64), dimension(nz+kz), intent(in)     :: zknot
    real(kind=real64), dimension(nx,ny,nz), intent(in)  :: bcoef
    real(kind=real64)                                   :: dbs3dr

    integer                       :: iz, nintz
    real(kind=real64), dimension(kz) :: work

!
!     check if knot(i) <= knot(i+1) and calculation of i so that
!     knot(i) <= x < knot(i+1)
!

    nintz = 0

    do iz = 1, nz+kz-1
       if (zknot(iz) .gt. zknot(iz + 1)) then
          write(6,*) "subroutine dbs3vl:"
          write(6,*) "zknot(iz) <= zknot(iz+1) required."
          write(6,*) iz, zknot(iz), zknot(iz+1)
          stop
       endif
       if((zknot(iz) .le. z) .and. (z .lt. zknot(iz + 1))) nintz = iz
    end do

    if(nintz .eq. 0) then
       write(6,*) "subroutine dbs3dr:"
       write(6,*) "iz with zknot(iz) <= z < zknot(iz+1) required."
       write(6,*) "zknot(iz)   = ", zknot(iz)
       write(6,*) "  z         = ", z
       write(6,*) "zknot(iz+1) = ", zknot(iz+1)
       stop
    endif

    do iz = 1, kz
       work(iz) = dbs2dr(iderx,idery,x,y,kx,ky,xknot,yknot,nx,ny,             &
            &        bcoef(1,1,nintz-kz+iz))
    end do

    dbs3dr = dbsder(iderz,z,kz,zknot(nintz-kz+1),kz,work)

  end function dbs3dr

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine dbs3gd(iderx,idery,iderz,nxvec,xvec,nyvec,yvec,nzvec,zvec,       &
       & kx,ky,kz,xknot,yknot,zknot,nx,ny,nz,bcoef,val,ldf,mdf)

!
!  Evaluates the derivative of a three-dimensional tensor-product spline,
!  given its tensor-product B-spline representation on a grid.
!
!   iderx  - order of the x-derivative.  (input)
!   idery  - order of the y-derivative.  (input)
!   iderz  - order of the z-derivative.  (input)
!   nx     - number of grid points in the x-direction.  (input)
!   xvec   - array of length nx containing the x-coordinates at
!            which the spline is to be evaluated.  (input)
!            the points in xvec should be strictly increasing.
!   ny     - number of grid points in the y-direction.  (input)
!   yvec   - array of length ny containing the y-coordinates at
!            which the spline is to be evaluated.  (input)
!            the points in yvec should be strictly increasing.
!   nz     - number of grid points in the z-direction.  (input)
!   zvec   - array of length nz containing the z-coordinates at
!            which the spline is to be evaluated.  (input)
!            the points in yvec should be strictly increasing.
!   kx     - order of the spline in the x-direction.  (input)
!   ky     - order of the spline in the y-direction.  (input)
!   kz     - order of the spline in the z-direction.  (input)
!   xknot  - array of length nx+kx containing the knot
!            sequence in the x-direction.  (input)
!            xknot must be nondecreasing.
!   yknot  - array of length ny+ky containing the knot
!            sequence in the y-direction.  (input)
!            yknot must be nondecreasing.
!   zknot  - array of length nz+kz containing the knot
!            sequence in the z-direction.  (input)
!            zknot must be nondecreasing.
!   nx     - number of B-spline coefficients in the x-direction.
!            (input)
!   ny     - number of B-spline coefficients in the y-direction.
!            (input)
!   nz     - number of B-spline coefficients in the z-direction.
!            (input)
!   bcoef  - array of length nx*ny*nz containing the
!            tensor-product B-spline coefficients.  (input)
!            bscoef is treated internally as a matrix of size nx
!            by ny by nz.
!   val    - array of size nx by ny by nz containing the values of
!            the (iderx,idery,iderz) derivative of the spline on the
!            nx by ny by nz grid.  (output)
!            value(i,j,k) contains the derivative of the spline at
!            the point (xvec(i), yvec(j), zvec(k)).
!   ldf    - leading dimension of value exactly as specified in the
!            dimension statement of the calling program.  (input)
!   mdf    - middle dimension of value exactly as specified in the
!            dimension statement of the calling program.  (input)
!

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                               :: iderx, idery, iderz
    integer, intent(in)                               :: nxvec, nyvec, nzvec
    integer, intent(in)                               :: kx, nx, ky, ny, kz, nz
    integer, intent(in)                               :: ldf,mdf

    real(kind=real64), dimension(nxvec), intent(in)      :: xvec
    real(kind=real64), dimension(nyvec), intent(in)      :: yvec
    real(kind=real64), dimension(nzvec), intent(in)      :: zvec
    real(kind=real64), dimension(nx+kx), intent(in)      :: xknot
    real(kind=real64), dimension(ny+ky), intent(in)      :: yknot
    real(kind=real64), dimension(nz+kz), intent(in)      :: zknot
    real(kind=real64), dimension(nx,ny,nz), intent(in)   :: bcoef
    real(kind=real64), dimension(ldf,mdf,*), intent(out) :: val

    integer                                           :: i, ik, il, ix, iy, iz
    integer                                           :: ikx, iky, ikz
    integer, dimension(nxvec)                         :: leftx
    integer, dimension(nyvec)                         :: lefty
    integer, dimension(nzvec)                         :: leftz
    real(kind=real64), dimension(nxvec,kx)               :: biatx
    real(kind=real64), dimension(nyvec,ky)               :: biaty
    real(kind=real64), dimension(nzvec,kz)               :: biatz
    real(kind=real64), dimension(max(nxvec,nyvec,nzvec)) :: term, save1

    real(kind=real64), dimension(max(nxvec,nyvec,nzvec), max(kx,ky,kz)) :: dl, dr

    logical :: same,next

    do i = 1, nx+kx-1
       if (xknot(i) .gt. xknot(i+1)) then
          write(6,*) "subroutine dbs3gd:"
          write(6,*) "xknot(i) <= xknot(i+1) required."
          write(6,*) i, xknot(i), xknot(i+1)
          write(6,*)
          write(6,*) xknot
          stop
       endif
    end do

    do i = 1, nxvec
       if ((xvec(i).lt.xknot(1)).or.(xvec(i).gt.xknot(nx+kx))) then
          write(6,*) "subroutine dbs3gd:"
          write(6,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
          write(6,*) "x = ", xvec(i)
          stop
       endif
    end do

    leftx(1) = 0

    call huntn(xknot,nx+kx,kx,xvec(1),leftx(1))

    do ix = 2, nxvec
       leftx(ix) = leftx(ix-1)
       same = (xknot(leftx(ix)) .le. xvec(ix))                                &
            &        .and. (xvec(ix) .le. xknot(leftx(ix)+1))
       if(.not. same ) then
          leftx(ix) = leftx(ix) + 1
          next      = (xknot(leftx(ix)) .le. xvec(ix))                        &
               &           .and. (xvec(ix) .le. xknot(leftx(ix)+1))
          if (.not. next) call huntn(xknot,nx+kx,kx,xvec(ix),leftx(ix))
       endif
    end do

    do i = 1, ny+ky-1
       if (yknot(i) .gt. yknot(i+1)) then
          write(6,*) "subroutine dbs3gd:"
          write(6,*) "yknot(i) <= yknot(i+1) required."
          write(6,*) i, yknot(i), yknot(i+1)
          write(6,*)
          write(6,*) yknot
          stop
       endif
    end do

    do i = 1, nyvec
       if ((yvec(i).lt.yknot(1)).or.(yvec(i).gt.yknot(ny+ky))) then
          write(6,*) "subroutine dbs3gd:"
          write(6,*) "iy with yknot(iy) <= y < yknot(iy+1) required."
          write(6,*) "y = ", yvec(i)
          stop
       endif
    end do

    lefty(1) = 0

    call huntn(yknot,ny+ky,ky,yvec(1),lefty(1))

    do iy = 2, nyvec
       lefty(iy) = lefty(iy-1)
       same = (yknot(lefty(iy)) .le. yvec(iy))                                &
            &        .and. (yvec(iy) .le. yknot(lefty(iy)+1))
       if(.not. same ) then
          lefty(iy) = lefty(iy) + 1
          next      = (yknot(lefty(iy)) .le. yvec(iy))                        &
               &           .and. (yvec(iy) .le. yknot(lefty(iy)+1))
          if (.not. next) call huntn(yknot,ny+ky,ky,yvec(iy),lefty(iy))
       endif
    end do

    do i = 1,nz+kz-1
       if (zknot(i) .gt. zknot(i+1)) then
          write(6,*) "subroutine dbs3gd:"
          write(6,*) "zknot(i) <= zknot(i+1) required."
          write(6,*) i, zknot(i), zknot(i+1)
          write(6,*)
          write(6,*) zknot
          stop
       endif
    end do

    do i = 1, nzvec
       if ((zvec(i).lt.zknot(1)).or.(zvec(i).gt.zknot(nz+kz))) then
          write(6,*) "subroutine dbs3gd:"
          write(6,*) "iz with zknot(iz) <= z < zknot(iz+1) required."
          write(6,*) "z = ", zvec(i)
          stop
       endif
    end do

    leftz(1) = 0

    call huntn(zknot,nz+kz,kz,zvec(1),leftz(1))

    do iz = 2, nzvec
       leftz(iz) = leftz(iz-1)
       same = (zknot(leftz(iz)) .le. zvec(iz))                                &
            &        .and. (zvec(iz) .le. zknot(leftz(iz)+1))
       if(.not. same ) then
          leftz(iz) = leftz(iz) + 1
          next      = (zknot(leftz(iz)) .le. zvec(iz))                        &
               &           .and. (zvec(iz) .le. zknot(leftz(iz)+1))
          if (.not. next) call huntn(zknot,nz+kz,kz,zvec(iz),leftz(iz))
       endif
    end do

    if ((iderx .eq. 0) .and. (idery .eq. 0) .and. (iderz .eq.0)) then

       do ix = 1, nxvec
          biatx(ix,1) = 1.0_real64
       end do

       do ik = 1, kx-1
          do ix = 1, nxvec
             dr(ix,ik) = xknot(leftx(ix)+ik) - xvec(ix)
             dl(ix,ik) = xvec(ix) - xknot(leftx(ix)+1-ik)
             save1(ix) = 0._real64
          end do

          do il = 1, ik
             do ix = 1, nxvec
                term(ix)     = biatx(ix,il) / (dr(ix,il) + dl(ix,ik+1-il))
                biatx(ix,il) = save1(ix) + dr(ix,il) * term(ix)
                save1(ix)    = dl(ix,ik+1-il) * term(ix)
             end do
          end do

          do ix = 1, nxvec
             biatx(ix,ik+1) = save1(ix)
          end do
       end do

       do iy = 1, nyvec
          biaty(iy,1) = 1.0_real64
       end do

       do ik = 1, ky-1
          do iy = 1, nyvec
             dr(iy,ik) = yknot(lefty(iy)+ik) - yvec(iy)
             dl(iy,ik) = yvec(iy) - yknot(lefty(iy)+1-ik)
             save1(iy) = 0._real64
          end do

          do il = 1,ik
             do iy = 1,nyvec
                term(iy)     = biaty(iy,il) / (dr(iy,il) + dl(iy,ik+1-il))
                biaty(iy,il) = save1(iy) + dr(iy,il) * term(iy)
                save1(iy)    = dl(iy,ik+1-il) * term(iy)
             end do
          end do

          do iy = 1,nyvec
             biaty(iy,ik+1) = save1(iy)
          end do
       end do

       do iz = 1,nzvec
          biatz(iz,1) = 1.0_real64
       end do

       do ik = 1, kz-1
          do iz = 1, nzvec
             dr(iz,ik) = zknot(leftz(iz)+ik) - zvec(iz)
             dl(iz,ik) = zvec(iz) - zknot(leftz(iz)+1-ik)
             save1(iz) = 0._real64
          end do

          do il = 1, ik
             do iz = 1, nzvec
                term(iz)     = biatz(iz,il) / (dr(iz,il) + dl(iz,ik+1-il))
                biatz(iz,il) = save1(iz) + dr(iz,il) * term(iz)
                save1(iz)    = dl(iz,ik+1-il) * term(iz)
             end do
          end do

          do iz = 1, nzvec
             biatz(iz,ik+1) = save1(iz)
          end do
       end do

       do iz = 1,nzvec
          do iy = 1,nyvec
             do ix = 1,nxvec
                val(ix,iy,iz) = 0.0_real64
             end do
          end do
       end do

       do ikz = 1, kz
          do iky = 1, ky
             do ikx = 1, kx
                do iz = 1, nzvec
                   do iy = 1, nyvec
                      do ix = 1, nxvec
                         val(ix,iy,iz) = val(ix,iy,iz)                        &
                              &  + biatx(ix,ikx) * biaty(iy,iky)              &
                              &  * biatz(iz,ikz)                              &
                              &  * bcoef(leftx(ix)-kx+ikx,                    &
                              &          lefty(iy)-ky+iky,leftz(iz)-kz+ikz)
                      end do
                   end do
                end do
             end do
          end do
       end do

    else

       do iz = 1, nzvec
          do iy = 1, nyvec
             do ix = 1, nxvec
                val(ix,iy,iz) = dbs3dr(iderx,idery,iderz,xvec(ix),            &
                     &  yvec(iy),zvec(iz),kx,ky,kz,xknot,yknot,               &
                     &  zknot,nx,ny,nz,bcoef)
             end do
          end do
       end do

    endif

  end subroutine dbs3gd

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine bsplvb(t,n,jhigh,index,x,left,biatx)

    use kind_mod, Only: real64

    implicit none

    integer, intent(in) :: n, jhigh, index, left

    real(kind=real64), intent(in)                    :: x
    real(kind=real64), dimension(n), intent(in)      :: t
    real(kind=real64), dimension(jhigh), intent(out) :: biatx

    integer                          :: j = 1
    integer                          :: i, jp1
    real(kind=real64)                   :: saved, term
    real(kind=real64), dimension(jhigh) :: dl, dr

    if (index .eq. 1) then
       j = 1
       biatx(1) = 1.0_real64
       if (j .ge. jhigh) return
    end if

20  jp1 = j + 1

    dr(j) = t(left+j) - x
    dl(j) = x - t(left+1-j)
    saved = 0._real64

    do i = 1, j
       term     = biatx(i) / (dr(i) + dl(jp1-i))
       biatx(i) = saved + dr(i) * term
       saved    = dl(jp1-i) * term
    end do

    biatx(jp1) = saved
    j          = jp1

    if (j .lt. jhigh) go to 20

  end subroutine bsplvb

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine banfac(w,nroww,nrow,nbandl,nbandu,iflag)

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                                  :: nroww,nrow
    integer, intent(in)                                  :: nbandl,nbandu
    integer, intent(out)                                 :: iflag
    real(kind=real64), dimension(nroww,nrow), intent(inout) :: w

    real(kind=real64) :: pivot, factor
    integer        :: middle, nrowm1, jmax, kmax, ipk, midmk, i, j, k

    iflag  = 1
    middle = nbandu + 1
    nrowm1 = nrow - 1

    if (nrowm1 .lt. 0) goto 999
    if (nrowm1 .eq. 0) goto 900
    if (nrowm1 .gt. 0) goto 10

10  if (nbandl .gt. 0) go to 30

    do i = 1, nrowm1
       if (w(middle,i) .eq. 0._real64) go to 999
    end do

    go to 900

30  if (nbandu .gt. 0) go to 60

    do i = 1, nrowm1
       pivot = w(middle,i)
       if(pivot .eq. 0._real64) go to 999
       jmax = min0(nbandl, nrow - i)
       do j = 1, jmax
          w(middle+j,i) = w(middle+j,i) / pivot
       end do
    end do

    return

60  do i = 1, nrowm1
       pivot = w(middle,i)
       if (pivot .eq. 0._real64) go to 999
       jmax = min0(nbandl,nrow - i)
       do j = 1,jmax
          w(middle+j,i) = w(middle+j,i) / pivot
       end do

       kmax = min0(nbandu,nrow - i)

       do k = 1, kmax
          ipk    = i + k
          midmk  = middle - k
          factor = w(midmk,ipk)
          do j = 1, jmax
             w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i)                  &
                  &              * factor
          end do
       end do
    end do

900 if (w(middle,nrow) .ne. 0._real64) return
999 iflag = 2

  end subroutine banfac

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine banslv(w,nroww,nrow,nbandl,nbandu,b)

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                               :: nroww,nrow
    integer, intent(in)                               :: nbandl,nbandu
    real(kind=real64), dimension(nroww,nrow), intent(in) :: w
    real(kind=real64), dimension(nrow), intent(inout)    :: b

    integer :: middle, nrowm1, jmax, i, j

    middle = nbandu + 1
    if (nrow .eq. 1) goto 99
    nrowm1 = nrow - 1
    if (nbandl .eq. 0) goto 30

    do i = 1, nrowm1
       jmax = min0(nbandl, nrow - i)
       do j = 1, jmax
          b(i+j) = b(i+j) - b(i) * w(middle+j,i)
       end do
    end do

30  if (nbandu .gt. 0)  goto 50

    do i = 1, nrow
       b(i) = b(i) / w(1,i)
    end do

    return

50  do i = nrow, 2, -1
       b(i) = b(i)/w(middle,i)
       jmax = min0(nbandu,i-1)
       do j = 1, jmax
          b(i-j) = b(i-j) - b(i) * w(middle-j,i)
       end do
    end do

99  b(1) = b(1) / w(middle,1)

  end subroutine banslv

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine huntn(xx,n,kord,x,jlo)

    use kind_mod, Only: real64

    implicit none

    integer, intent(in)                      :: n, kord
    real(kind=real64), intent(in)               :: x
    real(kind=real64), dimension(n), intent(in) :: xx

    integer, intent(out)                     :: jlo

    integer :: max, null, jhi, jm, inc

!
!     works only for B-Splines (order n)
!

    max  = n - kord
    null = kord

    if (jlo.le.null.or.jlo.gt.max) then
       jlo = null
       jhi = max+1
       goto 30
    endif

    inc = 1

    if (x .ge. xx(jlo)) then
10     jhi = jlo + inc
       if (jhi .gt. max) then
          jhi = max + 1
       else if (x .ge. xx(jhi)) then
          jlo = jhi
          inc = inc + inc
          goto 10
       endif
    else
       jhi = jlo
20     jlo = jhi - inc
       if (jlo .le. null) then
          jlo = null
       else if (x .lt. xx(jlo)) then
          jhi = jlo
          inc = inc + inc
          goto 20
       endif
    endif

30  if (jhi-jlo.eq.1) return

    jm = (jhi + jlo) / 2
    if (x .gt. xx(jm)) then
       jlo = jm
    else
       jhi = jm
    endif

    goto 30

  end subroutine huntn

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module bspline


CS    REAL FUNCTION GAMMA(X)
      DOUBLE PRECISION FUNCTION DGAMMACODY(X)
C----------------------------------------------------------------------
C
C This routine calculates the GAMMA function for a real argument X.
C   Computation is based on an algorithm outlined in reference 1.
C   The program uses rational functions that approximate the GAMMA
C   function to at least 20 significant decimal digits.  Coefficients
C   for the approximation over the interval (1,2) are unpublished.
C   Those for the approximation for X .GE. 12 are from reference 2.
C   The accuracy achieved depends on the arithmetic system, the
C   compiler, the intrinsic functions, and proper selection of the
C   machine-dependent constants.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C beta   - radix for the floating-point representation
C maxexp - the smallest positive power of beta that overflows
C XBIG   - the largest argument for which GAMMA(X) is representable
C          in the machine, i.e., the solution to the equation
C                  GAMMA(XBIG) = beta**maxexp
C XINF   - the largest machine representable floating-point number;
C          approximately beta**maxexp
C EPS    - the smallest positive floating-point number such that
C          1.0+EPS .GT. 1.0
C XMININ - the smallest positive floating-point number such that
C          1/XMININ is machine representable
C
C     Approximate values for some important machines are:
C
C                            beta       maxexp        XBIG
C
C CRAY-1         (S.P.)        2         8191        966.961
C Cyber 180/855
C   under NOS    (S.P.)        2         1070        177.803
C IEEE (IBM/XT,
C   SUN, etc.)   (S.P.)        2          128        35.040
C IEEE (IBM/XT,
C   SUN, etc.)   (D.P.)        2         1024        171.624
C IBM 3033       (D.P.)       16           63        57.574
C VAX D-Format   (D.P.)        2          127        34.844
C VAX G-Format   (D.P.)        2         1023        171.489
C
C                            XINF         EPS        XMININ
C
C CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
C Cyber 180/855
C   under NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
C IEEE (IBM/XT,
C   SUN, etc.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
C IEEE (IBM/XT,
C   SUN, etc.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
C IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
C VAX D-Format   (D.P.)   1.70D+38     1.39D-17    5.88D-39
C VAX G-Format   (D.P.)   8.98D+307    1.11D-16    1.12D-308
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for singularities or
C     when overflow would occur.  The computation is believed
C     to be free of underflow and overflow.
C
C
C  Intrinsic functions required are:
C
C     INT, DBLE, EXP, LOG, REAL, SIN
C
C
C References: "An Overview of Software Development for Special
C              Functions", W. J. Cody, Lecture Notes in Mathematics,
C              506, Numerical Analysis Dundee, 1975, G. A. Watson
C              (ed.), Springer Verlag, Berlin, 1976.
C
C              Computer Approximations, Hart, Et. Al., Wiley and
C              sons, New York, 1968.
C
C  Latest modification: October 12, 1989
C
C  Authors: W. J. Cody and L. Stoltz
C           Applied Mathematics Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C----------------------------------------------------------------------
*
*  A few modifs from Bruno (25 Feb 2005) from a Serge 's request:
*
*     - change the name of this function (DGAMMA ->  DGAMMACODY) to avoid conflict with
*       the gamma Slatec (file dgamma.f). (in fact thare was no conflict as this
*       function was retrieved in the makefile...)
*
*     - modify to get "better" values in some cases:
*
*         1/ when x is small we used more completly the equivalent gamma(x) ~ 1/x
*            (the original code uses it only if XMININ <= x < eps)
*            this lets to get  +-Inf for x = +-0
*         2/ when x is a negative integer return Nan (in place of XINF)
*         3/ when the gamma overflow return Inf (in place of XINF)
*       Serge asks me to change this in the Slatec gamma function but I try
*       first to do it in the Cody 's gamma... In fact to do a real job an
*       exception may be returned (with an integer flag say IERR) in theses
*       cases so as to prevent the user depending on the ieee scilab var.
*
      INTEGER I,N
      LOGICAL PARITY
CS    REAL
      DOUBLE PRECISION
     1    C,CONV,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE,
     2    TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
      DIMENSION C(7),P(8),Q(8)
C----------------------------------------------------------------------
C  Mathematical constants
C----------------------------------------------------------------------
CS    DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/,
CS   1     SQRTPI/0.9189385332046727417803297E0/,
CS   2     PI/3.1415926535897932384626434E0/
      DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/,
     1     SQRTPI/0.9189385332046727417803297D0/,
     2     PI/3.1415926535897932384626434D0/
C----------------------------------------------------------------------
C  Machine dependent parameters
C----------------------------------------------------------------------
CS    DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,
CS   1     XINF/3.4E38/
      DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/,
     1     XINF/1.79D308/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     approximation over (1,2).
C----------------------------------------------------------------------
CS    DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,
CS   1       -3.79804256470945635097577E+2,6.29331155312818442661052E+2,
CS   2       8.66966202790413211295064E+2,-3.14512729688483675254357E+4,
CS   3       -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
CS    DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,
CS   1      -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,
CS   2        2.25381184209801510330112E+4,4.75584627752788110767815E+3,
CS   3      -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
      DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1,
     1       -3.79804256470945635097577D+2,6.29331155312818442661052D+2,
     2       8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
     3       -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
      DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2,
     1      -1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
     2        2.25381184209801510330112D+4,4.75584627752788110767815D+3,
     3      -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
C----------------------------------------------------------------------
C  Coefficients for minimax approximation over (12, INF).
C----------------------------------------------------------------------
CS    DATA C/-1.910444077728E-03,8.4171387781295E-04,
CS   1     -5.952379913043012E-04,7.93650793500350248E-04,
CS   2     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
CS   3      5.7083835261E-03/
      DATA C/-1.910444077728D-03,8.4171387781295D-04,
     1     -5.952379913043012D-04,7.93650793500350248D-04,
     2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
     3      5.7083835261D-03/
C----------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
      CONV(I) = DBLE(I)
      PARITY = .FALSE.
      FACT = ONE
      N = 0
      Y = X

      if (abs(Y) .LT. EPS) then
*        argument is enough small (to use the equivalent 1/x)
         RES = ONE / Y
         goto 900

      ELSE IF (Y .LE. ZERO) THEN
C----------------------------------------------------------------------
C  Argument is negative
C----------------------------------------------------------------------
         Y = -X
         Y1 = AINT(Y)
         RES = Y - Y1
         IF (RES .NE. ZERO) THEN
            IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE.
            FACT = -PI / SIN(PI*RES)
            Y = Y + ONE
         ELSE
*          RES = XINF
* modif Bruno: return Nan (Y is a negative integer)
            RES = return_a_nan() ! this one is defined in somespline.f
            GO TO 900
         END IF
      END IF
C----------------------------------------------------------------------
C  Argument is positive
C----------------------------------------------------------------------
      IF (Y .LT. EPS) THEN
C----------------------------------------------------------------------
C  Argument .LT. EPS
C----------------------------------------------------------------------
*         IF (Y .GE. XMININ) THEN
         RES = ONE / Y
*         ELSE
*            RES = XINF
*            GO TO 900
*         END IF
      ELSE IF (Y .LT. TWELVE) THEN
         Y1 = Y
         IF (Y .LT. ONE) THEN
C----------------------------------------------------------------------
C  0.0 .LT. argument .LT. 1.0
C----------------------------------------------------------------------
            Z = Y
            Y = Y + ONE
         ELSE
C----------------------------------------------------------------------
C  1.0 .LT. argument .LT. 12.0, reduce argument if necessary
C----------------------------------------------------------------------
            N = INT(Y) - 1
            Y = Y - CONV(N)
            Z = Y - ONE
         END IF
C----------------------------------------------------------------------
C  Evaluate approximation for 1.0 .LT. argument .LT. 2.0
C----------------------------------------------------------------------
         XNUM = ZERO
         XDEN = ONE
         DO 260 I = 1, 8
            XNUM = (XNUM + P(I)) * Z
            XDEN = XDEN * Z + Q(I)
 260     CONTINUE
         RES = XNUM / XDEN + ONE
         IF (Y1 .LT. Y) THEN
C----------------------------------------------------------------------
C  Adjust result for case  0.0 .LT. argument .LT. 1.0
C----------------------------------------------------------------------
            RES = RES / Y1
         ELSE IF (Y1 .GT. Y) THEN
C----------------------------------------------------------------------
C  Adjust result for case  2.0 .LT. argument .LT. 12.0
C----------------------------------------------------------------------
            DO 290 I = 1, N
               RES = RES * Y
               Y = Y + ONE
 290        CONTINUE
         END IF
      ELSE
C----------------------------------------------------------------------
C  Evaluate for argument .GE. 12.0,
C----------------------------------------------------------------------
         IF (Y .LE. XBIG) THEN
            YSQ = Y * Y
            SUM = C(7)
            DO 350 I = 1, 6
               SUM = SUM / YSQ + C(I)
 350        CONTINUE
            SUM = SUM/Y - Y + SQRTPI
            SUM = SUM + (Y-HALF)*LOG(Y)
            RES = EXP(SUM)
         ELSE
*                  RES = XINF
* modif bruno : return an Inf
            RES = 2*XINF
* end modif bruno
            GO TO 900
         END IF
      END IF
C----------------------------------------------------------------------
C  Final adjustments and return
C----------------------------------------------------------------------
      IF (PARITY) RES = -RES
      IF (FACT .NE. ONE) RES = FACT / RES
CS900 GAMMA = RES
  900 DGAMMACODY = RES
      RETURN
C ---------- Last line of GAMMA ----------
      END


PROGRAM leggi
IMPLICIT none

integer:: i
integer, dimension(1:10) :: numero
real, dimension (1:10) :: teta, phi, tetarad, phirad
real, parameter :: pi=4*atan(1.)
Character*7 :: t, f

open (unit=1, FILE='/Volumes/FILIPPO/Fortran/dir.csv', STATUS='OLD')

!$OMP PARALLEL DO
DO i=1,10
READ (1,fmt='(I10,A9,F7.4,A6,F8.4)') numero(i), t, teta(i), f, phi(i)
END DO
!$OMP END PARALLEL DO

DO i=1,10
WRITE (*,fmt='(I10,A9,F8.4,A6,F8.4)') numero(i), t, teta(i), f, phi(i)
END DO

open(Unit=2, File='/Volumes/FILIPPO/Fortran/rad.csv', STATUS='REPLACE')

DO i=1,10
tetarad(i) = gradtorad(teta(i))
phirad(i) = gradtorad(phi(i))
WRITE (2,fmt='(I10,A9,F6.4,A6,F6.4)') numero(i), t, tetarad(i), f, phirad(i)
END DO

STOP

CONTAINS

REAL FUNCTION gradtorad(grad)
REAL :: grad
gradtorad=(grad*(2*pi))/360
END FUNCTION

END PROGRAM leggi


       subroutine jour_mois(ian,
     &                          ijour,imois)

       implicit none

       integer, intent(in)  :: ian
       integer, intent(out) :: ijour,imois, iday

       integer m1(12),m2(12),i,im,nan,njour

       data m1/31,59,90,120,151,181,212,243,273,304,334,365/
       data m2/31,60,91,121,152,182,213,244,274,305,335,366/

       ijour=mod(ian,1000)
       nan=(ian-ijour)/1000
       njour=mod(nan,4)

	do 10 i=1,12

	  if (njour.eq.0) then
	    if (ijour.gt.m2(i)) goto 10
            if (i.eq.1) then
            ijour=ijour
            else
	    ijour=ijour-m2(i-1)
            endif
            imois=i
	    goto 20
	  else
	    if (ijour.gt.m1(i)) goto 10
            if (i.eq.1) then
            ijour=ijour
            else
	    ijour=ijour-m1(i-1)
            endif
            imois=i
	    goto 20
	  endif

10	continue
20	continue

	return

	entry mois_jour(ian,iday)

	nan=ian/10000
	njour=mod(nan,4)
	iday=ian-nan*10000
	im=iday/100
	iday=iday-100*im
	if (im.gt.1) iday=iday+m1(im-1)
	if (njour.eq.0.and.im.ge.3) iday=iday+1

	return
	end


! Created by EverLookNeverSee@GitHub on 5/20/20.

!Module that contains a function subprogram F(x) = x + x 2 + π ,
!and a subroutine SWAP that swaps two variables a and b.

module library
    use constants
    contains
    function F(x)
        F = x + x ** 2 + pi
    end function F

    subroutine SWAP(a, b)
        temp = a
        a = b
        b = temp
    end subroutine SWAP
end module library


program subarray_test
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    use :: matrix_ops, only : print_matrix, print_vector
    implicit none
    integer, parameter :: m = 4, n = 5
    real(kind=dp), dimension(m, n) :: a
    real(kind=dp), dimension(m/2, n/2) :: b
    real(kind=dp), dimension(m -2) :: v
    integer :: i, j

    forall (i = 1:n, j = 1:n)
        a(i, j) = j + (i - 1)*n
    end forall
    call print_matrix(a, 'A')
    call print_vector(a(2, :), 'row 2 of A')
    call print_vector(a(:, 3), 'column 3 of A')
    call print_matrix(a(2:3, 2:4), 'subarray of A')
    a(2:3, 2:4) = 0.0_dp
    call print_matrix(a, 'A')
    b = a(1:m:2, 1:n:3)
    call print_matrix(b, 'B')
    b = a(::2, ::3)
    call print_matrix(b, 'B')
    v = a(3:, 1)
    call print_vector(v, 'v')

end program subarray_test


!----------------------------------------------------------------------------- best with 100 columns

function ILU1()
  use modSparse
  integer::ILU1
  type(ILU)::p
  integer::iA(7),jA(7)
  double precision::A(7)
  double precision::rhs(4),x(4)

  ILU1=0
  call p%init(4,7,4)
  iA=[1,2,2,3,3,4,4]
  jA=[1,2,1,3,4,4,2]
  A=[1d0,2d0,-1d0,5d0,-4d0,2d0,-1d0]
  rhs=[1d0,2d0,3d0,4d0]
  call p%setCOO(iA,jA,A,7)
  call p%fact(0d0)
  call p%solve(rhs,x)
  if(norm2(x-[1d0,3d0/2d0,14d0/5d0,11d0/4d0])>1d-9)then
    ILU1=1
  end if
end function


      function rnumread(par,string,delim,ia,ier,io)
c*******************************************
c  Find a parameter name in the character*700 string. Then find the real
c  number in the string enclosed by the symbols in delim.
c  There may be blanks before delim(1:1) and up to two blanks after it.
c  ier=1 - parameter not found in string, ier=2 - no left delimiter,
c  ier=3 - no right delimiter, ier=4 - no period, ier=5 - number > 999,999
c===========================================
      real rnumread
      real*8 mag,frac
      character*700 string
      character*20 par
      character*10 ac,buf
      character*2 delim
      intent(in) par,delim,io
      intent(out) ia,ier
c*******************************************
      ier=0
c  Find par
      nc=len_trim(par)
      ib=index(string,par(1:nc))
      if(ib==0) then
       ier=1
       return
      endif
      ia=index(string(ib:),delim(1:1))
      if(ia==0) then
       ier=2
       return
      endif
c  Position of first character in par
      ia=ia+ib
c  Trap blanks after delim(1:1)
      ic=index(string(ia:ia),' ')
      if(ic>0) then
       ia=ia+1
      endif
      ic=index(string(ia:ia),' ')
      if(ic>0) then
       ia=ia+1
      endif
c  Check for negative
      if(string(ia:ia)=='-') then
       rneg=-1.
       ia=ia+1
        else
         rneg=1.
      endif
      it=index(string(ia:),'.')
      if(it==0) then
       ier=4
       return
      endif
c  Size of number
      ic=it-1
      if(ic<8) then
       call number(string(ia:),ic,numag,io)
        else
         write(io,*) 'The number ',string(ia:),' > 9,999,999'
         ier=5
         return
      endif
      ib=ia+it
      buf=string(ib-1:)
c  Check on blank after period
      if(buf(2:2)==' ') then
       buf(2:2)='0'
      endif
      ic=index(buf(2:),delim(2:2))-1
      if(ic<=0) then
       ier=3
       return
      endif
      if(ic<7) then
       ac=buf(2:)
       call number(ac,ic,numfrac,io)
        else
         write(io,*) 'The number ',string(ib:),' > 9,999,999'
         ier=5
         return
      endif
      mag=dfloat(numag)
      frac=dfloat(numfrac)/dfloat(10**ic)
      rnumread=sngl(mag+frac)*rneg
c----------
      return
      end