!***************************************************************************************** !> author: Jacob Williams ! license: BSD ! !### Description ! ! Multidimensional (1D-6D) B-spline interpolation of data on a regular grid. ! Basic pure subroutine interface. ! !### Notes ! ! This module is based on the B-spline and spline routines from [1]. ! The original Fortran 77 routines were converted to free-form source. ! Some of them are relatively unchanged from the originals, but some have ! been extensively refactored. In addition, new routines for ! 1d, 4d, 5d, and 6d interpolation were also created (these are simply ! extensions of the same algorithm into higher dimensions). ! !### See also ! * An object-oriented interface can be found in [[bspline_oo_module]]. ! !### References ! ! 1. DBSPLIN and DTENSBS from the ! [NIST Core Math Library](http://www.nist.gov/itl/math/mcsd-software.cfm). ! Original code is public domain. ! 2. Carl de Boor, "A Practical Guide to Splines", ! Springer-Verlag, New York, 1978. ! 3. Carl de Boor, [Efficient Computer Manipulation of Tensor ! Products](http://dl.acm.org/citation.cfm?id=355831), ! ACM Transactions on Mathematical Software, ! Vol. 5 (1979), p. 173-182. ! 4. D.E. Amos, "Computation with Splines and B-Splines", ! SAND78-1968, Sandia Laboratories, March, 1979. ! 5. Carl de Boor, ! [Package for calculating with B-splines](http://epubs.siam.org/doi/abs/10.1137/0714026), ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), p. 441-472. ! 6. D.E. Amos, "Quadrature subroutines for splines and B-splines", ! Report SAND79-1825, Sandia Laboratories, December 1979. module bspline_sub_module use bspline_kinds_module, only: wp, ip use,intrinsic :: iso_fortran_env, only: error_unit implicit none private abstract interface function b1fqad_func(x) result(f) !! interface for the input function in [[dbfqad]] import :: wp implicit none real(wp),intent(in) :: x real(wp) :: f !! f(x) end function b1fqad_func end interface public :: b1fqad_func integer(ip),parameter,public :: bspline_order_linear = 2_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_quadratic = 3_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_cubic = 4_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_quartic = 5_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_quintic = 6_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_hexic = 7_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_heptic = 8_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] integer(ip),parameter,public :: bspline_order_octic = 9_ip !! spline order `k` parameter !! (for input to the `db*ink` routines) !! [order = polynomial degree + 1] real(wp),parameter :: root_ftol = 100.0_wp*epsilon(1.0_wp) !! relative tolerance on \( |s(x)-a| \) in !! [[db1root]] (scaled by the largest of \( |a| \) !! and the coefficient magnitudes): a value !! below it is treated as zero real(wp),parameter :: root_xtol = 64.0_wp*epsilon(1.0_wp) !! relative tolerance for duplicate roots in !! [[db1root]] (scaled by the width of the !! domain, see [[root_dup_tol]]) ! 8-point Gauss-Legendre abscissae (positive half) and weights on [-1,1], ! used by [[dbsgq8]] and [[dbfqad]]. These are the higher precision versions ! (about 300 digits) from http://pomax.github.io/bezierinfo/legendre-gauss.html, ! so more precision is obtained if `wp` is changed to, say, `real128`. real(wp),parameter :: gl8_x1 = & !! 8-point Gauss-Legendre abscissa 1 &0.1834346424956498049394761423601839806667578129129737823171884736992044& &742215421141160682237111233537452676587642867666089196012523876865683788& &569995160663568104475551617138501966385810764205532370882654749492812314& &961247764619363562770645716456613159405134052985058171969174306064445289& &638150514997832_wp real(wp),parameter :: gl8_x2 = & !! 8-point Gauss-Legendre abscissa 2 &0.5255324099163289858177390491892463490419642431203928577508570992724548& &207685612725239614001936319820619096829248252608507108793766638779939805& &395303668253631119018273032402360060717470006127901479587576756241288895& &336619643528330825624263470540184224603688817537938539658502113876953598& &879150514997832_wp real(wp),parameter :: gl8_x3 = & !! 8-point Gauss-Legendre abscissa 3 &0.7966664774136267395915539364758304368371717316159648320701702950392173& &056764730921471519272957259390191974534530973092653656494917010859602772& &562074621689676153935016290342325645582634205301545856060095727342603557& &415761265140428851957341933710803722783136113628137267630651413319993338& &002150514997832_wp real(wp),parameter :: gl8_x4 = & !! 8-point Gauss-Legendre abscissa 4 &0.9602898564975362316835608685694729904282352343014520382716397773724248& &977434192844394389592633122683104243928172941762102389581552171285479373& &642204909699700433982618326637346808781263553346927867359663480870597542& &547603929318533866568132868842613474896289232087639988952409772489387324& &25615051499783203_wp real(wp),parameter :: gl8_w1 = & !! 8-point Gauss-Legendre weight 1 &0.3626837833783619829651504492771956121941460398943305405248230675666867& &347239066773243660420848285095502587699262967065529258215569895173844995& &576007862076842778350382862546305771007553373269714714894268328780431822& &779077846722965535548199601402487767505928976560993309027632737537826127& &502150514997832_wp real(wp),parameter :: gl8_w2 = & !! 8-point Gauss-Legendre weight 2 &0.3137066458778872873379622019866013132603289990027349376902639450749562& &719421734969616980762339285560494275746410778086162472468322655616056890& &624276469758994622503118776562559463287222021520431626467794721603822601& &295276898652509723185157998353156062419751736972560423953923732838789657& &919150514997832_wp real(wp),parameter :: gl8_w3 = & !! 8-point Gauss-Legendre weight 3 &0.2223810344533744705443559944262408844301308700512495647259092892936168& &145704490408536531423771979278421592661012122181231114375798525722419381& &826674532090577908613289536840402789398648876004385697202157482063253247& &195590228631570651319965589733545440605952819880671616779621183704306688& &233150514997832_wp real(wp),parameter :: gl8_w4 = & !! 8-point Gauss-Legendre weight 4 &0.1012285362903762591525313543099621901153940910516849570590036980647401& &787634707848602827393040450065581543893314132667077154940308923487678731& &973041136073584690533208824050731976306575729205467961435779467552492328& &730055025992954089946676810510810729468366466585774650346143712142008566& &866150514997832_wp interface db1ink !! 1D initialization routines. module procedure :: db1ink_default, db1ink_alt, db1ink_alt_2, db1ink_multi end interface interface db1val !! 1D evaluation routines. module procedure :: db1val_default, db1val_alt, db1val_multi end interface interface db2ink !! 2D initialization routines. module procedure :: db2ink_default, db2ink_multi end interface interface db2val !! 2D evaluation routines. module procedure :: db2val_default, db2val_multi end interface interface db3ink !! 3D initialization routines. module procedure :: db3ink_default, db3ink_multi end interface interface db3val !! 3D evaluation routines. module procedure :: db3val_default, db3val_multi end interface interface db4ink !! 4D initialization routines. module procedure :: db4ink_default, db4ink_multi end interface interface db4val !! 4D evaluation routines. module procedure :: db4val_default, db4val_multi end interface interface db5ink !! 5D initialization routines. module procedure :: db5ink_default, db5ink_multi end interface interface db5val !! 5D evaluation routines. module procedure :: db5val_default, db5val_multi end interface interface db6ink !! 6D initialization routines. module procedure :: db6ink_default, db6ink_multi end interface interface db6val !! 6D evaluation routines. module procedure :: db6val_default, db6val_multi end interface !main routines: public :: db1ink, db1val, db1sqad, db1fqad public :: db1root, db1min, db1max public :: greville_abscissae public :: db2ink, db2val public :: db3ink, db3val public :: db4ink, db4val public :: db5ink, db5val public :: db6ink, db6val public :: get_status_message contains !***************************************************************************************** !***************************************************************************************** !> ! Determines the parameters of a function that interpolates ! the one-dimensional gridded data ! $$ [x(i),\mathrm{fcn}(i)] ~\mathrm{for}~ i=1,..,n_x $$ ! The interpolating function and its derivatives may ! subsequently be evaluated by the function [[db1val]]. ! !### History ! * Jacob Williams, 10/30/2015 : Created 1D routine. pure subroutine db1ink_default(x,nx,fcn,kx,iknot,tx,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) !! ( \( 2 \le k_x < n_x \) ) !! (order = polynomial degree + 1) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: fcn !! `(nx)` array of function values to interpolate. `fcn(i)` should !! contain the function value at the point `x(i)` integer(ip),intent(in) :: iknot !! knot sequence flag: !! !! * 0 = knot sequence chosen by [[db1ink]]. !! * 1 = knot sequence chosen by user. real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction !! for the spline interpolant: !! !! * If `iknot=0` these are chosen by [[db1ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(out) :: bcoef !! `(nx)` array of coefficients of the b-spline interpolant. integer(ip),intent(out) :: iflag !! status flag: !! !! * 0 = successful execution. !! * 2 = `iknot` out of range. !! * 3 = `nx` out of range. !! * 4 = `kx` out of range. !! * 5 = `x` not strictly increasing. !! * 6 = `tx` not non-decreasing. !! * 700 = `size(x)` \( \ne \) `size(fcn,1)`. !! * 706 = `size(x)` \( \ne \) `nx`. !! * 712 = `size(tx)` \( \ne \) `nx+kx`. !! * 800 = `size(x)` \( \ne \) `size(bcoef,1)`. logical :: status_ok real(wp),dimension(:),allocatable :: work !! work array of dimension `2*kx*(nx+1)` !check validity of inputs call check_inputs( iknot,& iflag,& nx=nx,& kx=kx,& x=x,& f1=fcn,& bcoef1=bcoef,& tx=tx,& status_ok=status_ok) if (status_ok) then !choose knots if (iknot == 0_ip) then call dbknot(x,nx,kx,tx) end if allocate(work(2_ip*kx*(nx+1_ip))) !construct b-spline coefficients call dbtpcf(x,nx,fcn,nx,1_ip,tx,kx,bcoef,work,iflag) deallocate(work) end if end subroutine db1ink_default !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[db1ink_default]], where the boundary conditions can be specified. ! !### History ! * Jacob Williams, 9/4/2018 : created this routine. ! !### See also ! * [[dbint4]] -- the main routine that is called here. ! !@note The spline order `kx` must be at least 3. pure subroutine db1ink_alt(x,nx,fcn,kx,ibcl,ibcr,fbcl,fbcr,kntopt,tx,bcoef,iflag) implicit none real(wp),dimension(:),intent(in) :: x !! \(x\) vector of abscissae of length `nx`, distinct !! and in increasing order integer(ip),intent(in) :: nx !! number of data points, \( n_x \ge \max(2,k_x-2) \) real(wp),dimension(:),intent(in) :: fcn !! \(y\) vector of ordinates of length `nx` integer(ip),intent(in) :: kx !! spline order (`kx >= 3`) integer(ip),intent(in) :: ibcl !! selection parameter for left boundary condition: !! constrain the `ibcl`-th derivative at `x(1)` to `fbcl` !! (`1 <= ibcl <= kx-1`, e.g. `ibcl = 2` for a natural spline) integer(ip),intent(in) :: ibcr !! selection parameter for right boundary condition: !! constrain the `ibcr`-th derivative at `x(nx)` to `fbcr` !! (`1 <= ibcr <= kx-1`, e.g. `ibcr = 2` for a natural spline) real(wp),intent(in) :: fbcl !! left boundary values governed by `ibcl` real(wp),intent(in) :: fbcr !! right boundary values governed by `ibcr` integer(ip),intent(in) :: kntopt !! knot selection parameter: !! !! * `kntopt = 1` sets knot multiplicity at `t(kx)` and !! `t(nx+3)` to `kx` !! * `kntopt = 2` sets a symmetric placement of knots !! about `t(kx)` and `t(nx+3)` real(wp),dimension(:),intent(out) :: tx !! knot array of length `nx+kx+2` real(wp),dimension(:),intent(out) :: bcoef !! b spline coefficient array of length `nx+2` integer(ip),intent(out) :: iflag !! status flag (see [[dbint4]]) integer(ip) :: n !! number of coefficients (n=nx+2) logical :: status_ok !! status flag for error checking real(wp),dimension(0),parameter :: tleft = 0.0_wp !! not used for this case (see [[dbint4]]) real(wp),dimension(0),parameter :: tright = 0.0_wp !! not used for this case (see [[dbint4]]) if (kntopt /= 1_ip .and. kntopt /= 2_ip) then iflag = 2005_ip ! use db1ink_alt_2 to specify the end knots else call check_inputs( 1_ip,& ! so it will check size of t iflag,& nx=nx,& kx=kx,& x=x,& f1=fcn,& bcoef1=bcoef,& tx=tx,& status_ok=status_ok,& alt=.true.) if (status_ok) then call dbint4(x,fcn,nx,ibcl,ibcr,fbcl,fbcr,kntopt,tleft,tright,tx,bcoef,n,kx,iflag) end if end if end subroutine db1ink_alt !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[db1ink_alt]], where the first and ! last `kx-1` knots are specified by the user. ! !### History ! * Jacob Williams, 9/4/2018 : created this routine. ! !### See also ! * [[dbint4]] -- the main routine that is called here. ! !@note The spline order `kx` must be at least 3. pure subroutine db1ink_alt_2(x,nx,fcn,kx,ibcl,ibcr,fbcl,fbcr,tleft,tright,tx,bcoef,iflag) implicit none real(wp),dimension(:),intent(in) :: x !! \(x\) vector of abscissae of length `nx`, distinct !! and in increasing order integer(ip),intent(in) :: nx !! number of data points, \( n_x \ge \max(2,k_x-2) \) real(wp),dimension(:),intent(in) :: fcn !! \(y\) vector of ordinates of length `nx` integer(ip),intent(in) :: kx !! spline order (`kx >= 3`) integer(ip),intent(in) :: ibcl !! selection parameter for left boundary condition: !! constrain the `ibcl`-th derivative at `x(1)` to `fbcl` !! (`1 <= ibcl <= kx-1`, e.g. `ibcl = 2` for a natural spline) integer(ip),intent(in) :: ibcr !! selection parameter for right boundary condition: !! constrain the `ibcr`-th derivative at `x(nx)` to `fbcr` !! (`1 <= ibcr <= kx-1`, e.g. `ibcr = 2` for a natural spline) real(wp),intent(in) :: fbcl !! left boundary values governed by `ibcl` real(wp),intent(in) :: fbcr !! right boundary values governed by `ibcr` real(wp),dimension(:),intent(in) :: tleft !! `t(1:kx-1)` in increasing order supplied by the user. real(wp),dimension(:),intent(in) :: tright !! `t(nx+4:nx+kx+2)` in increasing order supplied by the user. real(wp),dimension(:),intent(out) :: tx !! knot array of length `nx+kx+2` real(wp),dimension(:),intent(out) :: bcoef !! b spline coefficient array of length `nx+2` integer(ip),intent(out) :: iflag !! status flag (see [[dbint4]]) integer(ip) :: n !! number of coefficients (`n=nx+2`) logical :: status_ok !! status flag for error checking integer(ip),parameter :: kntopt = 3 !! use `tleft` and `tright` in [[dbint4]] call check_inputs( 1_ip,& ! so it will check size of t iflag,& nx=nx,& kx=kx,& x=x,& f1=fcn,& bcoef1=bcoef,& tx=tx,& status_ok=status_ok,& alt=.true.) if (status_ok) then call dbint4(x,fcn,nx,ibcl,ibcr,fbcl,fbcr,kntopt,tleft,tright,tx,bcoef,n,kx,iflag) end if end subroutine db1ink_alt_2 !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the tensor product piecewise polynomial ! interpolant constructed by the routine [[db1ink]] or one of its ! derivatives at the point `xval`. ! ! To evaluate the interpolant itself, set `idx=0`, ! to evaluate the first partial with respect to `x`, set `idx=1`, and so on. ! ! [[db1val]] returns 0.0 if (`xval`,`yval`) is out of range. that is, if !```fortran ! xval < tx(1) .or. xval > tx(nx+kx) !``` ! if the knots `tx` were chosen by [[db1ink]], then this is equivalent to: !```fortran ! xval < x(1) .or. xval > x(nx)+epsx !``` ! where !```fortran ! epsx = 0.1*(x(nx)-x(nx-1)) !``` ! ! The input quantities `tx`, `nx`, `kx`, and `bcoef` should be ! unchanged since the last call of [[db1ink]]. ! !### History ! * Jacob Williams, 10/30/2015 : Created 1D routine. pure subroutine db1val_default(xval,idx,tx,nx,kx,bcoef,f,iflag,inbvx,w0,extrap) implicit none integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). !! (same as in last call to [[db1ink]]) integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). !! (same as in last call to [[db1ink]]) real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),dimension(nx+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. (same as in last call to [[db1ink]]) real(wp),dimension(nx),intent(in) :: bcoef !! the b-spline coefficients computed by [[db1ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(3_ip*kx),intent(inout) :: w0 !! work array logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return call dbvalu(tx,bcoef,nx,kx,idx,xval,inbvx,w0,iflag,f,extrap) end subroutine db1val_default !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[db1val_default]] for use with [[db1ink_alt]] and [[db1ink_alt_2]]. pure subroutine db1val_alt(xval,idx,tx,nx,n,kx,bcoef,f,iflag,inbvx,w0,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: n !! length of `bcoef`: `nx+2` integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). !! (same as in last call to [[db1ink]]) real(wp),dimension(n+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. real(wp),dimension(n),intent(in) :: bcoef !! the b-spline coefficients computed by [[db1ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(3_ip*kx),intent(inout) :: w0 !! work array logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return call dbvalu(tx,bcoef,n,kx,idx,xval,inbvx,w0,iflag,f,extrap) end subroutine db1val_alt !***************************************************************************************** !***************************************************************************************** !> ! Computes the integral on `(x1,x2)` of a `kx`-th order b-spline. ! Orders `kx` as high as 20 are permitted by applying a 2, 6, or 10 ! point gauss formula on subintervals of `(x1,x2)` which are ! formed by included (distinct) knots. ! !### See also ! * [[dbsqad]] -- the core routine. pure subroutine db1sqad(tx,bcoef,nx,kx,x1,x2,f,iflag,w0) implicit none integer(ip),intent(in) :: nx !! length of coefficient array integer(ip),intent(in) :: kx !! order of b-spline, `1 <= k <= 20` real(wp),dimension(nx+kx),intent(in) :: tx !! knot array real(wp),dimension(nx),intent(in) :: bcoef !! b-spline coefficient array real(wp),intent(in) :: x1 !! left point of quadrature interval in `t(kx) <= x <= t(nx+1)` real(wp),intent(in) :: x2 !! right point of quadrature interval in `t(kx) <= x <= t(nx+1)` real(wp),intent(out) :: f !! integral of the b-spline over (`x1`,`x2`) integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error real(wp),dimension(3*kx),intent(inout) :: w0 !! work array for [[dbsqad]] call dbsqad(tx,bcoef,nx,kx,x1,x2,f,w0,iflag) end subroutine db1sqad !***************************************************************************************** !***************************************************************************************** !> ! Computes the integral on `(x1,x2)` of a product of a ! function `fun` and the `idx`-th derivative of a `kx`-th order b-spline, ! using the b-representation `(tx,bcoef,nx,kx)`, with an adaptive ! 8-point Legendre-Gauss algorithm. ! `(x1,x2)` must be a subinterval of `t(kx) <= x <= t(nx+1)`. ! !### See also ! * [[dbfqad]] -- the core routine. ! !@note This one is not pure, because we are not enforcing ! that the user function `fun` be pure. subroutine db1fqad(fun,tx,bcoef,nx,kx,idx,x1,x2,tol,f,iflag,w0) implicit none procedure(b1fqad_func) :: fun !! external function of one argument for the !! integrand `bf(x)=fun(x)*dbvalu(tx,bcoef,nx,kx,id,x,inbv,work)` integer(ip),intent(in) :: nx !! length of coefficient array integer(ip),intent(in) :: kx !! order of b-spline, `kx >= 1` real(wp),dimension(nx+kx),intent(in):: tx !! knot array real(wp),dimension(nx),intent(in) :: bcoef !! b-spline coefficient array integer(ip),intent(in) :: idx !! order of the spline derivative, `0 <= idx <= k-1` !! `idx=0` gives the spline function real(wp),intent(in) :: x1 !! left point of quadrature interval in `t(k) <= x <= t(n+1)` real(wp),intent(in) :: x2 !! right point of quadrature interval in `t(k) <= x <= t(n+1)` real(wp),intent(in) :: tol !! desired accuracy for the quadrature, suggest !! `10*dtol < tol <= 0.1` where `dtol` is the maximum !! of `1.0e-300` and real(wp) unit roundoff for !! the machine real(wp),intent(out) :: f !! integral of `bf(x)` on `(x1,x2)` integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error real(wp),dimension(3_ip*kx),intent(inout) :: w0 !! work array for [[dbfqad]] call dbfqad(fun,tx,bcoef,nx,kx,idx,x1,x2,tol,f,iflag,w0) end subroutine db1fqad !***************************************************************************************** !***************************************************************************************** !> ! Finds all the real roots of \( s(x) = a \) on \( t(k) \le x \le t(n+1) \), ! where \( s(x) \) is a 1D b-spline of order `kx` (`kx >= 2`). ! ! Each knot interval is examined separately: ! ! * By the convex hull property, if the `kx` coefficients that are ! nonzero on an interval are all above (or all below) `a`, the ! interval has no root and is skipped. ! * Otherwise, the polynomial piece is converted to Bernstein form ! (directly from the b-spline coefficients by blossoming, which is ! numerically stable for any order). Pieces of degree one or two are ! solved in closed form. Higher degree roots are isolated by Bernstein ! subdivision (Descartes' rule of signs) and refined with a ! safeguarded Newton iteration. ! * Roots of even multiplicity (where the spline touches `a` without ! crossing it) are found as the roots of \( s'(x) \) at which ! \( |s(x) - a| \) is within a small tolerance. ! ! If \( s(x) = a \) over a whole knot interval, the roots inside ! it are not returned (its end points are), and `iflag` is set to 4004. ! ! At an interior knot where the spline is discontinuous, \( s(x) \) is ! the value from the right (as for [[db1val]]), so a root of the piece ! on the left at the knot is not a root of the spline. ! !### Reference ! * K. Morken, M. Reimers, "An unconditionally convergent method for ! computing zeros of splines and polynomials", ! Mathematics of Computation, 76 (2007), 845-865. ! !### See also ! * [[db1min]], [[db1max]] pure subroutine db1root(tx,nx,kx,bcoef,a,roots,iflag) implicit none integer(ip),intent(in) :: nx !! number of b-spline coefficients integer(ip),intent(in) :: kx !! order of the b-spline, `kx >= 2` real(wp),dimension(nx+kx),intent(in) :: tx !! knot array real(wp),dimension(nx),intent(in) :: bcoef !! b-spline coefficient array real(wp),intent(in) :: a !! the value to solve for real(wp),dimension(:),allocatable,intent(out) :: roots !! the roots, in increasing order !! (size 0 if there are none) integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 4001: `kx` does not satisfy `kx >= 2` !! * 4002: `nx` does not satisfy `nx >= kx` !! * 4004: \( s(x) = a \) over a whole knot !! interval (other roots are still returned) real(wp),dimension(:),allocatable :: crit !! critical points (roots of \( s'(x) \)) real(wp),dimension(:),allocatable :: td !! knots of \( s'(x) \) real(wp),dimension(:),allocatable :: d !! coefficients of \( s'(x) \) real(wp),dimension(3*kx) :: work !! work array for [[dbvalu]] logical,dimension(:),allocatable :: keep !! roots to keep (those not replaced !! by a critical point) integer(ip) :: i !! counter integer(ip) :: j !! counter integer(ip) :: inbv !! initialization parameter for [[dbvalu]] integer(ip) :: iflag2 !! status flag from [[dbvalu]] and [[spline_roots]] !! for \( s'(x) \) (not returned) real(wp) :: f !! spline value \( s(x) \) real(wp) :: f2 !! second derivative \( s''(x) \) at a critical point real(wp) :: ftol !! absolute tolerance on \( |s(x)-a| \) real(wp) :: xtol !! distance below which two roots may be merged !! into a single root of even multiplicity real(wp) :: dmax !! distance from a root of even multiplicity within which !! other roots are replaced by it real(wp) :: band_max !! upper bound on `dmax` (for a root of higher multiplicity, !! where \( s''(x) = 0 \)) call check_root_inputs(nx,kx,iflag) if (iflag/=0_ip) then allocate(roots(0)) return end if call spline_roots(tx,bcoef,nx,kx,a,roots,iflag) ! roots of even multiplicity: critical points where s(x) is equal to a if (kx>=3_ip) then call spline_derivative(tx,bcoef,nx,kx,td,d) call spline_roots(td,d,nx-1_ip,kx-1_ip,0.0_wp,crit,iflag2) ftol = root_ftol * max(abs(a),maxval(abs(bcoef))) ! (the domain width is scaled before the subtraction, so it does not overflow) xtol = (sqrt(epsilon(1.0_wp))*tx(nx+1_ip) - sqrt(epsilon(1.0_wp))*tx(kx)) + & root_dup_tol(tx(kx),tx(nx+1_ip)) band_max = sqrt(sqrt(epsilon(1.0_wp)))*tx(nx+1_ip) - sqrt(sqrt(epsilon(1.0_wp)))*tx(kx) inbv = 1_ip do i = 1_ip, size(crit,kind=ip) call dbvalu(tx,bcoef,nx,kx,0_ip,crit(i),inbv,work,iflag2,f) if (iflag2/=0_ip) cycle if (abs(f-a)<=ftol) then if (iflag==4004_ip) then if (in_flat_region(tx,bcoef,nx,kx,a,ftol,crit(i))) cycle end if ! near a root of even multiplicity, the roots found above ! are only accurate to about sqrt(eps), but the critical ! point is accurate to about eps: replace any of them that ! are within the band around it where s(x) is within the ! noise level of `a`. For a double root, the half width ! of the band where |s(x)-a| <= ftol is sqrt(2*ftol/|s''|). ! Twice this is used, where |s(x)-a| <= 4*ftol. call dbvalu(tx,bcoef,nx,kx,2_ip,crit(i),inbv,work,iflag2,f2) dmax = band_max if (iflag2==0_ip .and. abs(f2)>0.0_wp) dmax = min(dmax, 2.0_wp*sqrt(2.0_wp*ftol/abs(f2))) dmax = max(dmax, xtol) allocate(keep(size(roots))) do j = 1_ip, size(roots,kind=ip) keep(j) = .true. if (abs(roots(j)-crit(i))<=dmax) then ! check that the spline is within the band between ! them (so they are not distinct roots) call dbvalu(tx,bcoef,nx,kx,0_ip,0.5_wp*(roots(j)+crit(i)),inbv,work,iflag2,f) keep(j) = .not. (iflag2==0_ip .and. abs(f-a)<=4.0_wp*ftol) end if end do roots = [pack(roots, keep), crit(i)] deallocate(keep) end if end do call sort_unique(roots, root_dup_tol(tx(kx),tx(nx+1_ip))) ! a root of even multiplicity may be split by rounding into a ! close pair of simple roots: merge them if the spline is ! within the noise level of `a` between them i = 1_ip do while (i<size(roots,kind=ip)) if (roots(i+1_ip)-roots(i)<=xtol) then call dbvalu(tx,bcoef,nx,kx,0_ip,0.5_wp*(roots(i)+roots(i+1_ip)),inbv,work,iflag2,f) if (iflag2==0_ip .and. abs(f-a)<=ftol) then roots(i) = 0.5_wp*(roots(i)+roots(i+1_ip)) roots = [roots(1_ip:i), roots(i+2_ip:)] cycle end if end if i = i + 1_ip end do end if end subroutine db1root !***************************************************************************************** !***************************************************************************************** !> ! Finds the global minimum of a 1D b-spline on \( [x_a, x_b] \). ! ! The candidates are the end points, the interior knots (where the ! derivative may be discontinuous), and the roots of \( s'(x) \). ! For `kx = 4` (cubic) the derivative pieces are quadratic, so the ! candidates are found in closed form. ! ! At an interior knot where the spline itself is discontinuous (a knot ! of multiplicity `kx` or more), \( s(x) \) is the value from the right, ! and the limit from the left is not attained. If that limit is the ! extremum, it is returned (with `xmin` at the knot) and `iflag` is set ! to 4007. ! !### See also ! * [[db1max]], [[db1root]] pure subroutine db1min(tx,nx,kx,bcoef,xa,xb,xmin,fmin,iflag) implicit none integer(ip),intent(in) :: nx !! number of b-spline coefficients integer(ip),intent(in) :: kx !! order of the b-spline, `kx >= 2` real(wp),dimension(nx+kx),intent(in) :: tx !! knot array real(wp),dimension(nx),intent(in) :: bcoef !! b-spline coefficient array real(wp),intent(in) :: xa !! left end of the interval, in `t(kx) <= x <= t(nx+1)` real(wp),intent(in) :: xb !! right end of the interval, in `t(kx) <= x <= t(nx+1)` real(wp),intent(out) :: xmin !! location of the minimum real(wp),intent(out) :: fmin !! minimum value of the spline integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 4001: `kx` does not satisfy `kx >= 2` !! * 4002: `nx` does not satisfy `nx >= kx` !! * 4003: `xa` or `xb` or both do not !! satisfy `t(kx) <= x <= t(nx+1)` !! * 4007: the minimum is the limit from the !! left at a discontinuity (not attained) call db1extremum(tx,nx,kx,bcoef,xa,xb,.false.,xmin,fmin,iflag) end subroutine db1min !***************************************************************************************** !***************************************************************************************** !> ! Finds the global maximum of a 1D b-spline on \( [x_a, x_b] \). ! See [[db1min]] for the method, and for discontinuous splines. ! !### See also ! * [[db1min]], [[db1root]] pure subroutine db1max(tx,nx,kx,bcoef,xa,xb,xmax,fmax,iflag) implicit none integer(ip),intent(in) :: nx !! number of b-spline coefficients integer(ip),intent(in) :: kx !! order of the b-spline, `kx >= 2` real(wp),dimension(nx+kx),intent(in) :: tx !! knot array real(wp),dimension(nx),intent(in) :: bcoef !! b-spline coefficient array real(wp),intent(in) :: xa !! left end of the interval, in `t(kx) <= x <= t(nx+1)` real(wp),intent(in) :: xb !! right end of the interval, in `t(kx) <= x <= t(nx+1)` real(wp),intent(out) :: xmax !! location of the maximum real(wp),intent(out) :: fmax !! maximum value of the spline integer(ip),intent(out) :: iflag !! status flag (see [[db1min]]) call db1extremum(tx,nx,kx,bcoef,xa,xb,.true.,xmax,fmax,iflag) end subroutine db1max !***************************************************************************************** !***************************************************************************************** !> ! Global minimum or maximum of a 1D b-spline on \( [x_a, x_b] \). ! Used by [[db1min]] and [[db1max]]. pure subroutine db1extremum(tx,nx,kx,bcoef,xa,xb,find_max,xopt,fopt,iflag) implicit none integer(ip),intent(in) :: nx !! number of b-spline coefficients integer(ip),intent(in) :: kx !! order of the b-spline, `kx >= 2` real(wp),dimension(nx+kx),intent(in) :: tx !! knot array real(wp),dimension(nx),intent(in) :: bcoef !! b-spline coefficient array real(wp),intent(in) :: xa !! one end of the interval real(wp),intent(in) :: xb !! other end of the interval logical,intent(in) :: find_max !! find the maximum (otherwise the minimum) real(wp),intent(out) :: xopt !! location of the extremum real(wp),intent(out) :: fopt !! value of the spline at `xopt` integer(ip),intent(out) :: iflag !! status flag (see [[db1min]]) real(wp),dimension(:),allocatable :: crit !! critical points (roots of \( s'(x) \)) real(wp),dimension(:),allocatable :: td !! knots of \( s'(x) \) real(wp),dimension(:),allocatable :: d !! coefficients of \( s'(x) \) real(wp),dimension(:),allocatable :: xc !! candidate points real(wp),dimension(3*kx) :: work !! work array for [[dbvalu]] real(wp),dimension(kx,1) :: vnikx !! basis function values from [[dbspvd]] real(wp),dimension((kx+1)*(kx+2)/2) :: work2 !! work array for [[dbspvd]] integer(ip) :: i !! counter integer(ip) :: m !! multiplicity of an interior knot integer(ip) :: inbv !! initialization parameter for [[dbvalu]] integer(ip) :: iflag2 !! status flag from [[spline_roots]] for \( s'(x) \) (not returned) real(wp) :: x1 !! left end of the interval: `min(xa,xb)` real(wp) :: x2 !! right end of the interval: `max(xa,xb)` real(wp) :: f !! spline value at a candidate point xopt = 0.0_wp fopt = 0.0_wp call check_root_inputs(nx,kx,iflag); if (iflag/=0_ip) return x1 = min(xa,xb) x2 = max(xa,xb) if (x1<tx(kx) .or. x2>tx(nx+1_ip)) then iflag = 4003_ip return end if ! candidates: the end points, the interior knots (the derivative ! may be discontinuous there), and the critical points xc = [x1, x2, pack(tx(kx+1_ip:nx), tx(kx+1_ip:nx)>x1 .and. tx(kx+1_ip:nx)<x2)] if (kx>=3_ip) then call spline_derivative(tx,bcoef,nx,kx,td,d) call spline_roots(td,d,nx-1_ip,kx-1_ip,0.0_wp,crit,iflag2) ! flat intervals are covered by the knots xc = [xc, pack(crit, crit>x1 .and. crit<x2)] end if inbv = 1_ip do i = 1_ip, size(xc,kind=ip) call dbvalu(tx,bcoef,nx,kx,0_ip,xc(i),inbv,work,iflag,f) if (iflag/=0_ip) return if (i==1_ip .or. (find_max .and. f>fopt) .or. (.not. find_max .and. f<fopt)) then xopt = xc(i) fopt = f end if end do ! the limits from the left at interior knots where the spline is ! discontinuous (multiplicity >= kx), in (x1,x2]. Each such knot is ! processed at the first of its copies, i, so interval i-1 is the ! nonempty interval to its left. do i = kx+1_ip, nx if (tx(i)<=x1 .or. tx(i)>x2 .or. tx(i)==tx(i-1_ip)) cycle m = 1_ip do while (i+m<=nx+kx) if (tx(i+m)/=tx(i)) exit m = m + 1_ip end do if (m<kx .or. tx(i)>=tx(nx+1_ip)) cycle ! continuous, or the right end (where ! s(x) is already the limit from the left) call dbspvd(tx,kx,1_ip,tx(i),i-1_ip,kx,vnikx,work2,iflag2) if (iflag2/=0_ip) cycle f = dot_product(vnikx(:,1), bcoef(i-kx:i-1_ip)) if ((find_max .and. f>fopt) .or. (.not. find_max .and. f<fopt)) then xopt = tx(i) fopt = f iflag = 4007_ip end if end do end subroutine db1extremum !***************************************************************************************** !***************************************************************************************** !> ! Greville abscissae of a b-spline: the average of the `k-1` interior ! knots of the support of each b-spline basis function, ! $$ \xi_i = \frac{t_{i+1} + \cdots + t_{i+k-1}}{k-1}, \quad i=1,\dots,n $$ ! ! The control points of a 1D b-spline are \( (\xi_i, c_i) \), where ! \( c_i \) are its coefficients. The spline lies within their convex ! hull, and the control polygon approximates the spline. In more than ! one dimension, the control net is the tensor product of the Greville ! abscissae in each direction, with the coefficient array. ! ! The Greville abscissae are also the coefficients of \( s(x) = x \) ! (for `k >= 2`), and are in \( [t_k, t_{n+1}] \) for clamped knots. ! For `k = 1`, the midpoints of the supports, \( (t_i + t_{i+1})/2 \), ! are returned. ! !### See also ! * The `control_points` method of [[bspline_1d]]. pure subroutine greville_abscissae(t,n,k,xi) implicit none integer(ip),intent(in) :: n !! number of b-spline coefficients integer(ip),intent(in) :: k !! order of the b-spline, `k >= 1` real(wp),dimension(n+k),intent(in) :: t !! knot array real(wp),dimension(n),intent(out) :: xi !! the Greville abscissae integer(ip) :: i !! counter if (k==1_ip) then xi = 0.5_wp*(t(1_ip:n) + t(2_ip:n+1_ip)) else do i = 1_ip, n ! the average, as an offset from the first knot (so it is exact ! for repeated knots, such as clamped ends), kept within the ! knots in case of rounding xi(i) = t(i+1_ip) + sum(t(i+2_ip:i+k-1_ip)-t(i+1_ip)) / real(k-1_ip,wp) xi(i) = min(max(xi(i), t(i+1_ip)), t(i+k-1_ip)) end do end if end subroutine greville_abscissae !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db1ink]]: interpolates `nf` functions ! on the same grid, with the same knots. The last dimension of `fcn` ! and `bcoef` is the output index. Evaluate them with [[db1val]] ! (multiple-output version). pure subroutine db1ink_multi(x,nx,fcn,kx,iknot,tx,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:,:),intent(in) :: fcn !! `(nx,nf)` array of function values to interpolate: !! `fcn(i1,j)` is output `j` at grid point !! (`x(i1)`) integer(ip),intent(in) :: iknot !! knot sequence flag (see [[db1ink_default]]) real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction real(wp),dimension(:,:),intent(out) :: bcoef !! `(nx,nf)` array of b-spline coefficients integer(ip),intent(out) :: iflag !! status flag (see [[db1ink_default]]), !! or 6001 if `fcn` and `bcoef` do not have the !! same number of outputs (or it is zero) integer(ip) :: nf !! number of outputs integer(ip) :: j !! output index nf = size(fcn,2,kind=ip) if (nf<1_ip .or. size(bcoef,2,kind=ip)/=nf) then iflag = 6001_ip return end if ! the knots are computed (if iknot=0) for the first output, and then reused do j = 1_ip, nf call db1ink_default(x,nx,fcn(:,j),kx,merge(iknot,1_ip,j==1_ip),& tx,bcoef(:,j),iflag) if (iflag/=0_ip) return end do end subroutine db1ink_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db1val]]: evaluates all `nf` outputs ! of a spline from [[db1ink]] (multiple-output version) at one point. ! The interval search and the basis functions in each direction are ! only computed once, for all of the outputs. pure subroutine db1val_multi(xval,idx,tx,nx,kx,bcoef,f,iflag,inbvx,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). real(wp),dimension(nx+kx),intent(in) :: tx !! knots in the \(x\) direction. real(wp),dimension(:,:),intent(in) :: bcoef !! `(nx,nf)` b-spline coefficients !! from [[db1ink]] (multiple-output version). real(wp),dimension(:),intent(out) :: f !! `(nf)` interpolated values of the outputs integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * 6002: `size(f)` is not the number of outputs !! * 6004: the leading dimensions of `bcoef` are not `(nx)` !! * other \( \ne 0 \) : error (see [[db1val]]) integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx !! interval index in \(x\) integer(ip) :: ix !! coefficient offset in \(x\) real(wp),dimension(kx) :: bx !! basis function weights in \(x\) integer(ip) :: jf !! output index f = 0.0_wp if (size(f,kind=ip)/=size(bcoef,2,kind=ip)) then iflag = 6002_ip return end if if (size(bcoef,1,kind=ip)/=nx) then iflag = 6004_ip return end if iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction (once for all outputs) call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx do jf = 1_ip, size(f,kind=ip) f(jf) = dot_product(bx,bcoef(ix+1_ip:leftx,jf)) end do end subroutine db1val_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db2ink]]: interpolates `nf` functions ! on the same grid, with the same knots. The last dimension of `fcn` ! and `bcoef` is the output index. Evaluate them with [[db2val]] ! (multiple-output version). pure subroutine db2ink_multi(x,nx,y,ny,fcn,kx,ky,iknot,tx,ty,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: ny !! Number of \(y\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. Must be strictly increasing. real(wp),dimension(:,:,:),intent(in) :: fcn !! `(nx,ny,nf)` array of function values to interpolate: !! `fcn(i1,i2,j)` is output `j` at grid point !! (`x(i1)`,`y(i2)`) integer(ip),intent(in) :: iknot !! knot sequence flag (see [[db2ink_default]]) real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction real(wp),dimension(:,:,:),intent(out) :: bcoef !! `(nx,ny,nf)` array of b-spline coefficients integer(ip),intent(out) :: iflag !! status flag (see [[db2ink_default]]), !! or 6001 if `fcn` and `bcoef` do not have the !! same number of outputs (or it is zero) integer(ip) :: nf !! number of outputs integer(ip) :: j !! output index nf = size(fcn,3,kind=ip) if (nf<1_ip .or. size(bcoef,3,kind=ip)/=nf) then iflag = 6001_ip return end if ! the knots are computed (if iknot=0) for the first output, and then reused do j = 1_ip, nf call db2ink_default(x,nx,y,ny,fcn(:,:,j),kx,ky,merge(iknot,1_ip,j==1_ip),& tx,ty,bcoef(:,:,j),iflag) if (iflag/=0_ip) return end do end subroutine db2ink_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db2val]]: evaluates all `nf` outputs ! of a spline from [[db2ink]] (multiple-output version) at one point. ! The interval search and the basis functions in each direction are ! only computed once, for all of the outputs. pure subroutine db2val_multi(xval,yval,idx,idy,tx,ty,nx,ny,kx,ky,bcoef,f,iflag,inbvx,iloy,w1,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). real(wp),dimension(nx+kx),intent(in) :: tx !! knots in the \(x\) direction. real(wp),dimension(ny+ky),intent(in) :: ty !! knots in the \(y\) direction. real(wp),dimension(:,:,:),intent(in) :: bcoef !! `(nx,ny,nf)` b-spline coefficients !! from [[db2ink]] (multiple-output version). real(wp),dimension(:),intent(out) :: f !! `(nf)` interpolated values of the outputs integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * 6002: `size(f)` is not the number of outputs !! * 6004: the leading dimensions of `bcoef` are not `(nx,ny)` !! * other \( \ne 0 \) : error (see [[db2val]]) integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloy !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx !! interval index in \(x\) integer(ip) :: lefty !! interval index in \(y\) integer(ip) :: ix !! coefficient offset in \(x\) integer(ip) :: iy !! coefficient offset in \(y\) real(wp),dimension(kx) :: bx !! basis function weights in \(x\) real(wp),dimension(ky) :: by !! basis function weights in \(y\) real(wp),dimension(ky),intent(inout) :: w1 !! work array of dimension `(ky)` integer(ip) :: j !! counter in \(y\) integer(ip) :: jf !! output index f = 0.0_wp if (size(f,kind=ip)/=size(bcoef,3,kind=ip)) then iflag = 6002_ip return end if if (size(bcoef,1,kind=ip)/=nx .or. & size(bcoef,2,kind=ip)/=ny) then iflag = 6004_ip return end if iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction (once for all outputs) call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky do jf = 1_ip, size(f,kind=ip) ! contract the coefficients one direction at a time do j=1_ip,ky w1(j) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,jf)) end do f(jf) = dot_product(by,w1) end do end subroutine db2val_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db3ink]]: interpolates `nf` functions ! on the same grid, with the same knots. The last dimension of `fcn` ! and `bcoef` is the output index. Evaluate them with [[db3val]] ! (multiple-output version). pure subroutine db3ink_multi(x,nx,y,ny,z,nz,fcn,kx,ky,kz,iknot,tx,ty,tz,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: ny !! Number of \(y\) abcissae integer(ip),intent(in) :: nz !! Number of \(z\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) integer(ip),intent(in) :: kz !! The order of spline pieces in \(z\) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. Must be strictly increasing. real(wp),dimension(:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nf)` array of function values to interpolate: !! `fcn(i1,i2,i3,j)` is output `j` at grid point !! (`x(i1)`,`y(i2)`,`z(i3)`) integer(ip),intent(in) :: iknot !! knot sequence flag (see [[db3ink_default]]) real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction real(wp),dimension(:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nf)` array of b-spline coefficients integer(ip),intent(out) :: iflag !! status flag (see [[db3ink_default]]), !! or 6001 if `fcn` and `bcoef` do not have the !! same number of outputs (or it is zero) integer(ip) :: nf !! number of outputs integer(ip) :: j !! output index nf = size(fcn,4,kind=ip) if (nf<1_ip .or. size(bcoef,4,kind=ip)/=nf) then iflag = 6001_ip return end if ! the knots are computed (if iknot=0) for the first output, and then reused do j = 1_ip, nf call db3ink_default(x,nx,y,ny,z,nz,fcn(:,:,:,j),kx,ky,kz,merge(iknot,1_ip,j==1_ip),& tx,ty,tz,bcoef(:,:,:,j),iflag) if (iflag/=0_ip) return end do end subroutine db3ink_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db3val]]: evaluates all `nf` outputs ! of a spline from [[db3ink]] (multiple-output version) at one point. ! The interval search and the basis functions in each direction are ! only computed once, for all of the outputs. pure subroutine db3val_multi(xval,yval,zval,idx,idy,idz,tx,ty,tz,nx,ny,nz,kx,ky,kz,bcoef,f,iflag,inbvx,iloy,iloz,w2,w1,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). real(wp),dimension(nx+kx),intent(in) :: tx !! knots in the \(x\) direction. real(wp),dimension(ny+ky),intent(in) :: ty !! knots in the \(y\) direction. real(wp),dimension(nz+kz),intent(in) :: tz !! knots in the \(z\) direction. real(wp),dimension(:,:,:,:),intent(in) :: bcoef !! `(nx,ny,nz,nf)` b-spline coefficients !! from [[db3ink]] (multiple-output version). real(wp),dimension(:),intent(out) :: f !! `(nf)` interpolated values of the outputs integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * 6002: `size(f)` is not the number of outputs !! * 6004: the leading dimensions of `bcoef` are not `(nx,ny,nz)` !! * other \( \ne 0 \) : error (see [[db3val]]) integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloy !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx !! interval index in \(x\) integer(ip) :: lefty !! interval index in \(y\) integer(ip) :: leftz !! interval index in \(z\) integer(ip) :: ix !! coefficient offset in \(x\) integer(ip) :: iy !! coefficient offset in \(y\) integer(ip) :: iz !! coefficient offset in \(z\) real(wp),dimension(kx) :: bx !! basis function weights in \(x\) real(wp),dimension(ky) :: by !! basis function weights in \(y\) real(wp),dimension(kz) :: bz !! basis function weights in \(z\) real(wp),dimension(ky,kz),intent(inout) :: w2 !! work array of dimension `(ky,kz)` real(wp),dimension(kz),intent(inout) :: w1 !! work array of dimension `(kz)` integer(ip) :: j !! counter in \(y\) integer(ip) :: k !! counter in \(z\) integer(ip) :: jf !! output index f = 0.0_wp if (size(f,kind=ip)/=size(bcoef,4,kind=ip)) then iflag = 6002_ip return end if if (size(bcoef,1,kind=ip)/=nx .or. & size(bcoef,2,kind=ip)/=ny .or. & size(bcoef,3,kind=ip)/=nz) then iflag = 6004_ip return end if iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction (once for all outputs) call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz do jf = 1_ip, size(f,kind=ip) ! contract the coefficients one direction at a time do k=1_ip,kz do j=1_ip,ky w2(j,k) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,jf)) end do w1(k) = dot_product(by,w2(:,k)) end do f(jf) = dot_product(bz,w1) end do end subroutine db3val_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db4ink]]: interpolates `nf` functions ! on the same grid, with the same knots. The last dimension of `fcn` ! and `bcoef` is the output index. Evaluate them with [[db4val]] ! (multiple-output version). pure subroutine db4ink_multi(x,nx,y,ny,z,nz,q,nq,fcn,kx,ky,kz,kq,iknot,tx,ty,tz,tq,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: ny !! Number of \(y\) abcissae integer(ip),intent(in) :: nz !! Number of \(z\) abcissae integer(ip),intent(in) :: nq !! Number of \(q\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) integer(ip),intent(in) :: kz !! The order of spline pieces in \(z\) integer(ip),intent(in) :: kq !! The order of spline pieces in \(q\) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: q !! `(nq)` array of \(q\) abcissae. Must be strictly increasing. real(wp),dimension(:,:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nq,nf)` array of function values to interpolate: !! `fcn(i1,i2,i3,i4,j)` is output `j` at grid point !! (`x(i1)`,`y(i2)`,`z(i3)`,`q(i4)`) integer(ip),intent(in) :: iknot !! knot sequence flag (see [[db4ink_default]]) real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction real(wp),dimension(:),intent(inout) :: tq !! The `(nq+kq)` knots in the \(q\) direction real(wp),dimension(:,:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nq,nf)` array of b-spline coefficients integer(ip),intent(out) :: iflag !! status flag (see [[db4ink_default]]), !! or 6001 if `fcn` and `bcoef` do not have the !! same number of outputs (or it is zero) integer(ip) :: nf !! number of outputs integer(ip) :: j !! output index nf = size(fcn,5,kind=ip) if (nf<1_ip .or. size(bcoef,5,kind=ip)/=nf) then iflag = 6001_ip return end if ! the knots are computed (if iknot=0) for the first output, and then reused do j = 1_ip, nf call db4ink_default(x,nx,y,ny,z,nz,q,nq,fcn(:,:,:,:,j),kx,ky,kz,kq,merge(iknot,1_ip,j==1_ip),& tx,ty,tz,tq,bcoef(:,:,:,:,j),iflag) if (iflag/=0_ip) return end do end subroutine db4ink_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db4val]]: evaluates all `nf` outputs ! of a spline from [[db4ink]] (multiple-output version) at one point. ! The interval search and the basis functions in each direction are ! only computed once, for all of the outputs. pure subroutine db4val_multi(xval,yval,zval,qval,idx,idy,idz,idq,tx,ty,tz,tq,nx,ny,nz,nq,kx,ky,kz,kq,bcoef,f,iflag,inbvx,iloy,iloz,iloq,w3,w2,w1,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),intent(in) :: qval !! \(q\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idq !! \(q\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). integer(ip),intent(in) :: nq !! the number of interpolation points in \(q\). integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). integer(ip),intent(in) :: kq !! order of polynomial pieces in \(q\). real(wp),dimension(nx+kx),intent(in) :: tx !! knots in the \(x\) direction. real(wp),dimension(ny+ky),intent(in) :: ty !! knots in the \(y\) direction. real(wp),dimension(nz+kz),intent(in) :: tz !! knots in the \(z\) direction. real(wp),dimension(nq+kq),intent(in) :: tq !! knots in the \(q\) direction. real(wp),dimension(:,:,:,:,:),intent(in) :: bcoef !! `(nx,ny,nz,nq,nf)` b-spline coefficients !! from [[db4ink]] (multiple-output version). real(wp),dimension(:),intent(out) :: f !! `(nf)` interpolated values of the outputs integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * 6002: `size(f)` is not the number of outputs !! * 6004: the leading dimensions of `bcoef` are not `(nx,ny,nz,nq)` !! * other \( \ne 0 \) : error (see [[db4val]]) integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloy !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloq !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx !! interval index in \(x\) integer(ip) :: lefty !! interval index in \(y\) integer(ip) :: leftz !! interval index in \(z\) integer(ip) :: leftq !! interval index in \(q\) integer(ip) :: ix !! coefficient offset in \(x\) integer(ip) :: iy !! coefficient offset in \(y\) integer(ip) :: iz !! coefficient offset in \(z\) integer(ip) :: iq !! coefficient offset in \(q\) real(wp),dimension(kx) :: bx !! basis function weights in \(x\) real(wp),dimension(ky) :: by !! basis function weights in \(y\) real(wp),dimension(kz) :: bz !! basis function weights in \(z\) real(wp),dimension(kq) :: bq !! basis function weights in \(q\) real(wp),dimension(ky,kz,kq),intent(inout) :: w3 !! work array of dimension `(ky,kz,kq)` real(wp),dimension(kz,kq),intent(inout) :: w2 !! work array of dimension `(kz,kq)` real(wp),dimension(kq),intent(inout) :: w1 !! work array of dimension `(kq)` integer(ip) :: j !! counter in \(y\) integer(ip) :: k !! counter in \(z\) integer(ip) :: q !! counter in \(q\) integer(ip) :: jf !! output index f = 0.0_wp if (size(f,kind=ip)/=size(bcoef,5,kind=ip)) then iflag = 6002_ip return end if if (size(bcoef,1,kind=ip)/=nx .or. & size(bcoef,2,kind=ip)/=ny .or. & size(bcoef,3,kind=ip)/=nz .or. & size(bcoef,4,kind=ip)/=nq) then iflag = 6004_ip return end if iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return iflag = check_value(qval,tq,4_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction (once for all outputs) call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tq,nq,kq,idq,qval,iloq,leftq,bq,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz iq = leftq - kq do jf = 1_ip, size(f,kind=ip) ! contract the coefficients one direction at a time do q=1_ip,kq do k=1_ip,kz do j=1_ip,ky w3(j,k,q) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,iq+q,jf)) end do w2(k,q) = dot_product(by,w3(:,k,q)) end do w1(q) = dot_product(bz,w2(:,q)) end do f(jf) = dot_product(bq,w1) end do end subroutine db4val_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db5ink]]: interpolates `nf` functions ! on the same grid, with the same knots. The last dimension of `fcn` ! and `bcoef` is the output index. Evaluate them with [[db5val]] ! (multiple-output version). pure subroutine db5ink_multi(x,nx,y,ny,z,nz,q,nq,r,nr,fcn,kx,ky,kz,kq,kr,iknot,tx,ty,tz,tq,tr,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: ny !! Number of \(y\) abcissae integer(ip),intent(in) :: nz !! Number of \(z\) abcissae integer(ip),intent(in) :: nq !! Number of \(q\) abcissae integer(ip),intent(in) :: nr !! Number of \(r\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) integer(ip),intent(in) :: kz !! The order of spline pieces in \(z\) integer(ip),intent(in) :: kq !! The order of spline pieces in \(q\) integer(ip),intent(in) :: kr !! The order of spline pieces in \(r\) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: q !! `(nq)` array of \(q\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: r !! `(nr)` array of \(r\) abcissae. Must be strictly increasing. real(wp),dimension(:,:,:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nq,nr,nf)` array of function values to interpolate: !! `fcn(i1,i2,i3,i4,i5,j)` is output `j` at grid point !! (`x(i1)`,`y(i2)`,`z(i3)`,`q(i4)`,`r(i5)`) integer(ip),intent(in) :: iknot !! knot sequence flag (see [[db5ink_default]]) real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction real(wp),dimension(:),intent(inout) :: tq !! The `(nq+kq)` knots in the \(q\) direction real(wp),dimension(:),intent(inout) :: tr !! The `(nr+kr)` knots in the \(r\) direction real(wp),dimension(:,:,:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nq,nr,nf)` array of b-spline coefficients integer(ip),intent(out) :: iflag !! status flag (see [[db5ink_default]]), !! or 6001 if `fcn` and `bcoef` do not have the !! same number of outputs (or it is zero) integer(ip) :: nf !! number of outputs integer(ip) :: j !! output index nf = size(fcn,6,kind=ip) if (nf<1_ip .or. size(bcoef,6,kind=ip)/=nf) then iflag = 6001_ip return end if ! the knots are computed (if iknot=0) for the first output, and then reused do j = 1_ip, nf call db5ink_default(x,nx,y,ny,z,nz,q,nq,r,nr,fcn(:,:,:,:,:,j),kx,ky,kz,kq,kr,merge(iknot,1_ip,j==1_ip),& tx,ty,tz,tq,tr,bcoef(:,:,:,:,:,j),iflag) if (iflag/=0_ip) return end do end subroutine db5ink_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db5val]]: evaluates all `nf` outputs ! of a spline from [[db5ink]] (multiple-output version) at one point. ! The interval search and the basis functions in each direction are ! only computed once, for all of the outputs. pure subroutine db5val_multi(xval,yval,zval,qval,rval,idx,idy,idz,idq,idr,tx,ty,tz,tq,tr,nx,ny,nz,nq,nr,kx,ky,kz,kq,kr,bcoef,f,iflag,inbvx,iloy,iloz,iloq,ilor,w4,w3,w2,w1,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),intent(in) :: qval !! \(q\) coordinate of evaluation point. real(wp),intent(in) :: rval !! \(r\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idq !! \(q\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idr !! \(r\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). integer(ip),intent(in) :: nq !! the number of interpolation points in \(q\). integer(ip),intent(in) :: nr !! the number of interpolation points in \(r\). integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). integer(ip),intent(in) :: kq !! order of polynomial pieces in \(q\). integer(ip),intent(in) :: kr !! order of polynomial pieces in \(r\). real(wp),dimension(nx+kx),intent(in) :: tx !! knots in the \(x\) direction. real(wp),dimension(ny+ky),intent(in) :: ty !! knots in the \(y\) direction. real(wp),dimension(nz+kz),intent(in) :: tz !! knots in the \(z\) direction. real(wp),dimension(nq+kq),intent(in) :: tq !! knots in the \(q\) direction. real(wp),dimension(nr+kr),intent(in) :: tr !! knots in the \(r\) direction. real(wp),dimension(:,:,:,:,:,:),intent(in) :: bcoef !! `(nx,ny,nz,nq,nr,nf)` b-spline coefficients !! from [[db5ink]] (multiple-output version). real(wp),dimension(:),intent(out) :: f !! `(nf)` interpolated values of the outputs integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * 6002: `size(f)` is not the number of outputs !! * 6004: the leading dimensions of `bcoef` are not `(nx,ny,nz,nq,nr)` !! * other \( \ne 0 \) : error (see [[db5val]]) integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloy !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloq !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: ilor !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx !! interval index in \(x\) integer(ip) :: lefty !! interval index in \(y\) integer(ip) :: leftz !! interval index in \(z\) integer(ip) :: leftq !! interval index in \(q\) integer(ip) :: leftr !! interval index in \(r\) integer(ip) :: ix !! coefficient offset in \(x\) integer(ip) :: iy !! coefficient offset in \(y\) integer(ip) :: iz !! coefficient offset in \(z\) integer(ip) :: iq !! coefficient offset in \(q\) integer(ip) :: ir !! coefficient offset in \(r\) real(wp),dimension(kx) :: bx !! basis function weights in \(x\) real(wp),dimension(ky) :: by !! basis function weights in \(y\) real(wp),dimension(kz) :: bz !! basis function weights in \(z\) real(wp),dimension(kq) :: bq !! basis function weights in \(q\) real(wp),dimension(kr) :: br !! basis function weights in \(r\) real(wp),dimension(ky,kz,kq,kr),intent(inout) :: w4 !! work array of dimension `(ky,kz,kq,kr)` real(wp),dimension(kz,kq,kr),intent(inout) :: w3 !! work array of dimension `(kz,kq,kr)` real(wp),dimension(kq,kr),intent(inout) :: w2 !! work array of dimension `(kq,kr)` real(wp),dimension(kr),intent(inout) :: w1 !! work array of dimension `(kr)` integer(ip) :: j !! counter in \(y\) integer(ip) :: k !! counter in \(z\) integer(ip) :: q !! counter in \(q\) integer(ip) :: r !! counter in \(r\) integer(ip) :: jf !! output index f = 0.0_wp if (size(f,kind=ip)/=size(bcoef,6,kind=ip)) then iflag = 6002_ip return end if if (size(bcoef,1,kind=ip)/=nx .or. & size(bcoef,2,kind=ip)/=ny .or. & size(bcoef,3,kind=ip)/=nz .or. & size(bcoef,4,kind=ip)/=nq .or. & size(bcoef,5,kind=ip)/=nr) then iflag = 6004_ip return end if iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return iflag = check_value(qval,tq,4_ip,extrap); if (iflag/=0_ip) return iflag = check_value(rval,tr,5_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction (once for all outputs) call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tq,nq,kq,idq,qval,iloq,leftq,bq,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tr,nr,kr,idr,rval,ilor,leftr,br,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz iq = leftq - kq ir = leftr - kr do jf = 1_ip, size(f,kind=ip) ! contract the coefficients one direction at a time do r=1_ip,kr do q=1_ip,kq do k=1_ip,kz do j=1_ip,ky w4(j,k,q,r) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,iq+q,ir+r,jf)) end do w3(k,q,r) = dot_product(by,w4(:,k,q,r)) end do w2(q,r) = dot_product(bz,w3(:,q,r)) end do w1(r) = dot_product(bq,w2(:,r)) end do f(jf) = dot_product(br,w1) end do end subroutine db5val_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db6ink]]: interpolates `nf` functions ! on the same grid, with the same knots. The last dimension of `fcn` ! and `bcoef` is the output index. Evaluate them with [[db6val]] ! (multiple-output version). pure subroutine db6ink_multi(x,nx,y,ny,z,nz,q,nq,r,nr,s,ns,fcn,kx,ky,kz,kq,kr,ks,iknot,tx,ty,tz,tq,tr,ts,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: ny !! Number of \(y\) abcissae integer(ip),intent(in) :: nz !! Number of \(z\) abcissae integer(ip),intent(in) :: nq !! Number of \(q\) abcissae integer(ip),intent(in) :: nr !! Number of \(r\) abcissae integer(ip),intent(in) :: ns !! Number of \(s\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) integer(ip),intent(in) :: kz !! The order of spline pieces in \(z\) integer(ip),intent(in) :: kq !! The order of spline pieces in \(q\) integer(ip),intent(in) :: kr !! The order of spline pieces in \(r\) integer(ip),intent(in) :: ks !! The order of spline pieces in \(s\) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: q !! `(nq)` array of \(q\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: r !! `(nr)` array of \(r\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: s !! `(ns)` array of \(s\) abcissae. Must be strictly increasing. real(wp),dimension(:,:,:,:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nq,nr,ns,nf)` array of function values to interpolate: !! `fcn(i1,i2,i3,i4,i5,i6,j)` is output `j` at grid point !! (`x(i1)`,`y(i2)`,`z(i3)`,`q(i4)`,`r(i5)`,`s(i6)`) integer(ip),intent(in) :: iknot !! knot sequence flag (see [[db6ink_default]]) real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction real(wp),dimension(:),intent(inout) :: tq !! The `(nq+kq)` knots in the \(q\) direction real(wp),dimension(:),intent(inout) :: tr !! The `(nr+kr)` knots in the \(r\) direction real(wp),dimension(:),intent(inout) :: ts !! The `(ns+ks)` knots in the \(s\) direction real(wp),dimension(:,:,:,:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nq,nr,ns,nf)` array of b-spline coefficients integer(ip),intent(out) :: iflag !! status flag (see [[db6ink_default]]), !! or 6001 if `fcn` and `bcoef` do not have the !! same number of outputs (or it is zero) integer(ip) :: nf !! number of outputs integer(ip) :: j !! output index nf = size(fcn,7,kind=ip) if (nf<1_ip .or. size(bcoef,7,kind=ip)/=nf) then iflag = 6001_ip return end if ! the knots are computed (if iknot=0) for the first output, and then reused do j = 1_ip, nf call db6ink_default(x,nx,y,ny,z,nz,q,nq,r,nr,s,ns,fcn(:,:,:,:,:,:,j),kx,ky,kz,kq,kr,ks,merge(iknot,1_ip,j==1_ip),& tx,ty,tz,tq,tr,ts,bcoef(:,:,:,:,:,:,j),iflag) if (iflag/=0_ip) return end do end subroutine db6ink_multi !***************************************************************************************** !***************************************************************************************** !> ! Multiple-output version of [[db6val]]: evaluates all `nf` outputs ! of a spline from [[db6ink]] (multiple-output version) at one point. ! The interval search and the basis functions in each direction are ! only computed once, for all of the outputs. pure subroutine db6val_multi(xval,yval,zval,qval,rval,sval,idx,idy,idz,idq,idr,ids,tx,ty,tz,tq,tr,ts,nx,ny,nz,nq,nr,ns,kx,ky,kz,kq,kr,ks,bcoef,f,iflag,inbvx,iloy,iloz,iloq,ilor,ilos,w5,w4,w3,w2,w1,extrap) implicit none real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),intent(in) :: qval !! \(q\) coordinate of evaluation point. real(wp),intent(in) :: rval !! \(r\) coordinate of evaluation point. real(wp),intent(in) :: sval !! \(s\) coordinate of evaluation point. integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idq !! \(q\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idr !! \(r\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: ids !! \(s\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). integer(ip),intent(in) :: nq !! the number of interpolation points in \(q\). integer(ip),intent(in) :: nr !! the number of interpolation points in \(r\). integer(ip),intent(in) :: ns !! the number of interpolation points in \(s\). integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). integer(ip),intent(in) :: kq !! order of polynomial pieces in \(q\). integer(ip),intent(in) :: kr !! order of polynomial pieces in \(r\). integer(ip),intent(in) :: ks !! order of polynomial pieces in \(s\). real(wp),dimension(nx+kx),intent(in) :: tx !! knots in the \(x\) direction. real(wp),dimension(ny+ky),intent(in) :: ty !! knots in the \(y\) direction. real(wp),dimension(nz+kz),intent(in) :: tz !! knots in the \(z\) direction. real(wp),dimension(nq+kq),intent(in) :: tq !! knots in the \(q\) direction. real(wp),dimension(nr+kr),intent(in) :: tr !! knots in the \(r\) direction. real(wp),dimension(ns+ks),intent(in) :: ts !! knots in the \(s\) direction. real(wp),dimension(:,:,:,:,:,:,:),intent(in) :: bcoef !! `(nx,ny,nz,nq,nr,ns,nf)` b-spline coefficients !! from [[db6ink]] (multiple-output version). real(wp),dimension(:),intent(out) :: f !! `(nf)` interpolated values of the outputs integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * 6002: `size(f)` is not the number of outputs !! * 6004: the leading dimensions of `bcoef` are not `(nx,ny,nz,nq,nr,ns)` !! * other \( \ne 0 \) : error (see [[db6val]]) integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloy !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloq !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: ilor !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: ilos !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx !! interval index in \(x\) integer(ip) :: lefty !! interval index in \(y\) integer(ip) :: leftz !! interval index in \(z\) integer(ip) :: leftq !! interval index in \(q\) integer(ip) :: leftr !! interval index in \(r\) integer(ip) :: lefts !! interval index in \(s\) integer(ip) :: ix !! coefficient offset in \(x\) integer(ip) :: iy !! coefficient offset in \(y\) integer(ip) :: iz !! coefficient offset in \(z\) integer(ip) :: iq !! coefficient offset in \(q\) integer(ip) :: ir !! coefficient offset in \(r\) integer(ip) :: is !! coefficient offset in \(s\) real(wp),dimension(kx) :: bx !! basis function weights in \(x\) real(wp),dimension(ky) :: by !! basis function weights in \(y\) real(wp),dimension(kz) :: bz !! basis function weights in \(z\) real(wp),dimension(kq) :: bq !! basis function weights in \(q\) real(wp),dimension(kr) :: br !! basis function weights in \(r\) real(wp),dimension(ks) :: bs !! basis function weights in \(s\) real(wp),dimension(ky,kz,kq,kr,ks),intent(inout) :: w5 !! work array of dimension `(ky,kz,kq,kr,ks)` real(wp),dimension(kz,kq,kr,ks),intent(inout) :: w4 !! work array of dimension `(kz,kq,kr,ks)` real(wp),dimension(kq,kr,ks),intent(inout) :: w3 !! work array of dimension `(kq,kr,ks)` real(wp),dimension(kr,ks),intent(inout) :: w2 !! work array of dimension `(kr,ks)` real(wp),dimension(ks),intent(inout) :: w1 !! work array of dimension `(ks)` integer(ip) :: j !! counter in \(y\) integer(ip) :: k !! counter in \(z\) integer(ip) :: q !! counter in \(q\) integer(ip) :: r !! counter in \(r\) integer(ip) :: s !! counter in \(s\) integer(ip) :: jf !! output index f = 0.0_wp if (size(f,kind=ip)/=size(bcoef,7,kind=ip)) then iflag = 6002_ip return end if if (size(bcoef,1,kind=ip)/=nx .or. & size(bcoef,2,kind=ip)/=ny .or. & size(bcoef,3,kind=ip)/=nz .or. & size(bcoef,4,kind=ip)/=nq .or. & size(bcoef,5,kind=ip)/=nr .or. & size(bcoef,6,kind=ip)/=ns) then iflag = 6004_ip return end if iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return iflag = check_value(qval,tq,4_ip,extrap); if (iflag/=0_ip) return iflag = check_value(rval,tr,5_ip,extrap); if (iflag/=0_ip) return iflag = check_value(sval,ts,6_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction (once for all outputs) call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tq,nq,kq,idq,qval,iloq,leftq,bq,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tr,nr,kr,idr,rval,ilor,leftr,br,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ts,ns,ks,ids,sval,ilos,lefts,bs,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz iq = leftq - kq ir = leftr - kr is = lefts - ks do jf = 1_ip, size(f,kind=ip) ! contract the coefficients one direction at a time do s=1_ip,ks do r=1_ip,kr do q=1_ip,kq do k=1_ip,kz do j=1_ip,ky w5(j,k,q,r,s) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,iq+q,ir+r,is+s,jf)) end do w4(k,q,r,s) = dot_product(by,w5(:,k,q,r,s)) end do w3(q,r,s) = dot_product(bz,w4(:,q,r,s)) end do w2(r,s) = dot_product(bq,w3(:,r,s)) end do w1(s) = dot_product(br,w2(:,s)) end do f(jf) = dot_product(bs,w1) end do end subroutine db6val_multi !***************************************************************************************** !***************************************************************************************** !> ! Check the inputs to [[db1root]], [[db1min]], and [[db1max]]. pure subroutine check_root_inputs(nx,kx,iflag) implicit none integer(ip),intent(in) :: nx !! number of b-spline coefficients integer(ip),intent(in) :: kx !! order of the b-spline integer(ip),intent(out) :: iflag !! status flag if (kx<2_ip) then iflag = 4001_ip else if (nx<kx) then iflag = 4002_ip else iflag = 0_ip end if end subroutine check_root_inputs !***************************************************************************************** !***************************************************************************************** !> ! The derivative of a b-spline, as a b-spline of order `k-1` ! with `n-1` coefficients and knots `t(2:n+k-1)`, times a positive ! constant (so it has the same roots). ! ! The constant is chosen (as a power of 2, so the scaling is exact) to ! avoid overflow for large coefficients or closely spaced knots. It is ! only used for the roots of \( s'(x) \). pure subroutine spline_derivative(t,c,n,k,td,d) implicit none integer(ip),intent(in) :: n !! number of b-spline coefficients integer(ip),intent(in) :: k !! order of the b-spline, `k >= 2` real(wp),dimension(n+k),intent(in) :: t !! knot array real(wp),dimension(n),intent(in) :: c !! b-spline coefficient array real(wp),dimension(:),allocatable,intent(out) :: td !! knots of the derivative (size `n+k-2`) real(wp),dimension(:),allocatable,intent(out) :: d !! coefficients of the derivative (size `n-1`) integer(ip) :: i !! counter real(wp) :: dt !! support width of a b-spline basis function: `t(i+k-1) - t(i)` (scaled) real(wp) :: cs !! scale factor for the coefficients (a power of 2) real(wp) :: ts !! scale factor for the knots (a power of 2) cs = pow2(maxval(abs(c))) ts = pow2(max(abs(t(1)),abs(t(n+k)))) td = t(2_ip:n+k-1_ip) allocate(d(n-1_ip)) do i = 2_ip, n dt = t(i+k-1_ip)/ts - t(i)/ts if (dt>0.0_wp) then d(i-1_ip) = real(k-1_ip,wp) * (c(i)/cs - c(i-1_ip)/cs) / dt else d(i-1_ip) = 0.0_wp ! the basis function is identically zero end if end do contains pure function pow2(x) result(p) !! The largest power of 2 not greater than `x` (1 if `x` is 0). !! (so it is representable for any finite `x`) real(wp),intent(in) :: x !! the value (`x >= 0`) real(wp) :: p !! the power of 2 if (x>0.0_wp) then p = scale(1.0_wp, exponent(x)-1) else p = 1.0_wp end if end function pow2 end subroutine spline_derivative !***************************************************************************************** !***************************************************************************************** !> ! Roots of \( s(x) = a \) where the spline crosses `a` (or where a ! root lies exactly on a knot). Roots of even multiplicity may be ! missed. Used by [[db1root]]. pure subroutine spline_roots(t,c,n,k,a,roots,iflag) implicit none integer(ip),intent(in) :: n !! number of b-spline coefficients integer(ip),intent(in) :: k !! order of the b-spline, `k >= 1` real(wp),dimension(n+k),intent(in) :: t !! knot array real(wp),dimension(n),intent(in) :: c !! b-spline coefficient array real(wp),intent(in) :: a !! the value to solve for real(wp),dimension(:),allocatable,intent(out) :: roots !! the roots, in increasing order integer(ip),intent(out) :: iflag !! 0, or 4004 if \( s(x) = a \) on a whole interval real(wp),dimension(0:k-1) :: p !! power basis coefficients of a piece, on \( u \in [0,1] \) !! (for the closed form roots of degree 1 and 2) real(wp),dimension(0:k-1) :: b !! Bernstein coefficients of a piece minus `a`, on \( u \in [0,1] \) real(wp),dimension(k) :: cl !! local b-spline coefficients minus `a` real(wp),dimension(3*k) :: work !! work array for [[dbvalu]] real(wp),dimension(:),allocatable :: u !! roots of a piece, on \( u \in [0,1] \) real(wp),dimension(:),allocatable :: xr !! roots of a piece, on \( x \in [t_l, t_{l+1}] \) logical,dimension(:),allocatable :: keep !! roots to keep integer(ip) :: l !! knot interval index: `t(l) <= x < t(l+1)` integer(ip) :: i !! counter integer(ip) :: m !! polynomial degree of the pieces: `k-1` integer(ip) :: inbv !! initialization parameter for [[dbvalu]] integer(ip) :: ierr !! status flag from [[dbvalu]] real(wp) :: h !! width of the knot interval: `t(l+1) - t(l)` real(wp) :: val !! spline value from [[dbvalu]] real(wp) :: ftol !! absolute tolerance on \( |s(x)-a| \) real(wp),parameter :: utol = 16.0_wp*epsilon(1.0_wp) !! accept roots just outside the interval !! \( [0,1] \) (they are moved to the end) iflag = 0_ip allocate(roots(0)) m = k - 1_ip ! polynomial degree ftol = root_ftol * max(abs(a),maxval(abs(c))) inbv = 1_ip ! end points (a root here may not be a sign change after rounding) call dbvalu(t,c,n,k,0_ip,t(k),inbv,work,ierr,val) if (ierr==0_ip .and. abs(val-a)<=ftol) roots = [roots, t(k)] call dbvalu(t,c,n,k,0_ip,t(n+1_ip),inbv,work,ierr,val) if (ierr==0_ip .and. abs(val-a)<=ftol) roots = [roots, t(n+1_ip)] do l = k, n if (t(l)>=t(l+1_ip)) cycle ! empty interval cl = c(l-k+1_ip:l) - a ! s(x) = a on the whole interval. Its left end is a root (it may ! not be found from the previous interval, where it may be a ! root of high multiplicity). The right end is found from the ! next interval (or is the end of the domain). The roots inside ! a flat region are removed below. if (maxval(abs(cl))<=ftol) then iflag = 4004_ip roots = [roots, t(l)] cycle end if ! convex hull: no root in this interval if (all(cl>ftol) .or. all(cl<-ftol)) cycle ! Bernstein form of the piece on u in [0,1], with x = t(l) + h*u h = t(l+1_ip) - t(l) b = bernstein_coefficients() ! root at the knot (the pieces on either side are computed ! separately, so it may not be a sign change after rounding) if (abs(b(0))<=ftol) roots = [roots, t(l)] select case (m) case(1_ip) p(0:1) = [b(0), b(1)-b(0)] u = linear_root() case(2_ip) p(0:2) = [b(0), 2.0_wp*(b(1)-b(0)), b(0)-2.0_wp*b(1)+b(2)] u = quadratic_roots() case(3_ip:) u = bernstein_roots() case default u = [real(wp) ::] ! constant piece end select ! keep the roots in the interval (allowing for rounding at the ends) u = pack(u, u>=-utol .and. u<=1.0_wp+utol) xr = min(t(l+1_ip), t(l) + h*min(1.0_wp,max(0.0_wp,u))) if (t(l+1_ip)<t(n+1_ip)) then ! a root at the right end is the limit from the left. At an ! interior knot, s(x) is the value from the right, which is ! different if the spline is discontinuous there. A root at ! the knot is found from the next nonempty interval instead. xr = pack(xr, xr<t(l+1_ip)) end if roots = [roots, xr] end do call sort_unique(roots, root_dup_tol(t(k),t(n+1_ip))) ! remove the roots inside regions where s(x) = a (only the ends are kept) if (iflag==4004_ip) then allocate(keep(size(roots))) do i = 1_ip, size(roots,kind=ip) keep(i) = .not. in_flat_region(t,c,n,k,a,ftol,roots(i)) end do roots = pack(roots, keep) end if contains pure function bernstein_coefficients() result(bc) !! Bernstein coefficients of the piece on knot interval `l`, minus `a`. !! !! The `i`-th coefficient is the blossom of the piece evaluated at !! `m-i` copies of `t(l)` and `i` copies of `t(l+1)`, computed with !! de Boor's algorithm using these as the arguments at each level. !! Every step is a convex combination, so the coefficients are !! accurate to about `eps*max(|c|)` for any order (unlike the power !! basis computed from the derivatives, which loses accuracy at the !! right end of the interval for high orders). real(wp),dimension(0:m) :: bc !! the Bernstein coefficients real(wp),dimension(0:m) :: w !! de Boor triangle (`w(i)` is for coefficient `l-m+i`) real(wp) :: x !! the argument at the current level real(wp) :: alpha !! interpolation weight integer(ip) :: ib !! index of the Bernstein coefficient integer(ip) :: r !! level of the de Boor triangle integer(ip) :: jj !! counter integer(ip) :: jc !! b-spline coefficient index: `l-m+jj` do ib = 0_ip, m w = cl do r = 1_ip, m x = merge(t(l), t(l+1_ip), r<=m-ib) do jj = m, r, -1_ip jc = l - m + jj alpha = (x - t(jc)) / (t(jc+m+1_ip-r) - t(jc)) w(jj) = alpha*w(jj) + (1.0_wp-alpha)*w(jj-1_ip) end do end do bc(ib) = w(m) end do end function bernstein_coefficients pure function linear_root() result(ur) !! Root of a linear piece \( p_0 + p_1 u \). real(wp),dimension(:),allocatable :: ur !! the root, on \( u \) (size 0 if \( p_1 = 0 \)) if (p(1)/=0.0_wp) then ur = [-p(0)/p(1)] else allocate(ur(0)) end if end function linear_root pure function quadratic_roots() result(ur) !! Roots of a quadratic piece \( p_0 + p_1 u + p_2 u^2 \) !! (numerically stable form of the quadratic formula). real(wp),dimension(:),allocatable :: ur !! the real roots, on \( u \) (size 0, 1, or 2) real(wp),dimension(0:2) :: ps !! the coefficients, scaled so the largest !! magnitude is 1 (so that the discriminant !! does not overflow or underflow) real(wp) :: disc !! discriminant: \( p_1^2 - 4 p_2 p_0 \) (scaled) real(wp) :: q !! \( -\frac{1}{2} \left( p_1 + \mathrm{sign}(p_1) \sqrt{disc} \right) \) !! (the roots are \( q/p_2 \) and \( p_0/q \)) (scaled) if (p(2)==0.0_wp) then ur = linear_root() return end if allocate(ur(0)) ps = p(0:2) / maxval(abs(p(0:2))) disc = ps(1)**2 - 4.0_wp*ps(2)*ps(0) if (disc<0.0_wp) return q = -0.5_wp * (ps(1) + sign(sqrt(disc),ps(1))) ur = [q/ps(2)] if (q/=0.0_wp) ur = [ur, ps(0)/q] end function quadratic_roots pure function bernstein_roots() result(ur) !! Isolate the roots of a piece by Bernstein subdivision, !! and refine each with a safeguarded Newton iteration. !! !! Subintervals are processed from a stack. The left half of a !! divided subinterval is processed first, so at most one right !! half per depth is waiting, and the stack never holds more !! than `max_depth+2` entries. real(wp),dimension(:),allocatable :: ur !! the roots, on \( u \in [0,1] \) integer(ip),parameter :: max_depth = 52_ip !! maximum number of subdivisions !! (the interval width is then \( 2^{-52} \)) real(wp),dimension(0:m,max_depth+2) :: bs !! stack of Bernstein coefficients real(wp),dimension(max_depth+2) :: uas !! stack of left ends of the subintervals real(wp),dimension(max_depth+2) :: ubs !! stack of right ends of the subintervals integer(ip),dimension(max_depth+2) :: deps !! stack of subdivision depths real(wp),dimension(0:m) :: bb !! Bernstein coefficients on the current subinterval real(wp),dimension(0:m) :: left !! Bernstein coefficients on the left half real(wp),dimension(0:m) :: right !! Bernstein coefficients on the right half real(wp),dimension(0:m) :: tmp !! work array for de Casteljau's algorithm integer(ip) :: top !! top of the stack (0 if empty) integer(ip) :: nsign !! number of sign changes in `bb` (an upper bound !! on the number of roots in the subinterval) integer(ip) :: dep !! subdivision depth of the current subinterval integer(ip) :: r !! counter integer(ip) :: s !! counter real(wp) :: ua !! left end of the current subinterval real(wp) :: ub !! right end of the current subinterval real(wp) :: um !! midpoint of the current subinterval real(wp) :: sprev !! sign of the previous nonzero coefficient (0 if none yet) allocate(ur(0)) top = 1_ip bs(:,1) = b uas(1) = 0.0_wp ubs(1) = 1.0_wp deps(1) = 0_ip do while (top>0_ip) bb = bs(:,top) ua = uas(top) ub = ubs(top) dep = deps(top) top = top - 1_ip ! the piece is within the noise level of zero on this interval ! (a multiple root): keep it if the sign changes across the ! interval (odd multiplicity), otherwise it is found by db1root if (maxval(abs(bb))<=ftol) then if (bb(0)*bb(m)<0.0_wp) ur = [ur, 0.5_wp*(ua+ub)] cycle end if ! number of sign changes (Descartes' rule of signs), ! where coefficients within the noise level count as zero nsign = 0_ip sprev = 0.0_wp do r = 0_ip, m if (abs(bb(r))>ftol) then if (sprev/=0.0_wp .and. sign(1.0_wp,bb(r))/=sprev) nsign = nsign + 1_ip sprev = sign(1.0_wp,bb(r)) end if end do if (nsign==0_ip) cycle if (nsign==1_ip .and. abs(bb(0))>ftol .and. abs(bb(m))>ftol) then ! exactly one simple root (and none at the ends) ur = [ur, newton(ua,ub)] cycle end if if (dep>=max_depth) then ur = [ur, 0.5_wp*(ua+ub)] ! cluster of roots cycle end if ! subdivide at the midpoint (de Casteljau) tmp = bb do r = 1_ip, m left(r-1_ip) = tmp(0) right(m-r+1_ip) = tmp(m-r+1_ip) do s = 0_ip, m-r tmp(s) = 0.5_wp*(tmp(s)+tmp(s+1_ip)) end do end do left(m) = tmp(0) right(0) = tmp(0) um = 0.5_wp*(ua+ub) if (abs(tmp(0))<=ftol) ur = [ur, um] ! root at the midpoint top = top + 1_ip bs(:,top) = right uas(top) = um ubs(top) = ub deps(top) = dep + 1_ip top = top + 1_ip bs(:,top) = left uas(top) = ua ubs(top) = um deps(top) = dep + 1_ip end do end function bernstein_roots pure function newton(ua,ub) result(u) !! Safeguarded Newton iteration for the single root of the !! piece in `[ua,ub]` (bisection when the Newton step leaves !! the bracket, or does not reduce it quickly enough). real(wp),intent(in) :: ua !! left end of the bracket real(wp),intent(in) :: ub !! right end of the bracket real(wp) :: u !! the root, on \( u \in [u_a,u_b] \) integer(ip),parameter :: max_iter = 200_ip !! maximum number of iterations integer(ip) :: iter !! iteration counter real(wp) :: xl !! end of the bracket where the piece is negative real(wp) :: xh !! end of the bracket where the piece is positive real(wp) :: f !! value of the piece at `u` real(wp) :: df !! derivative of the piece at `u` real(wp) :: fl !! value of the piece at `ua` real(wp) :: fh !! value of the piece at `ub` real(wp) :: dx !! the last step real(wp) :: dxold !! the step before the last one real(wp) :: temp !! previous value of `u` call bernstein_eval(ua,fl,df) call bernstein_eval(ub,fh,df) if (fl==0.0_wp) then u = ua; return else if (fh==0.0_wp) then u = ub; return else if (fl*fh>0.0_wp) then ! no sign change after rounding: take the closest end u = merge(ua,ub,abs(fl)<abs(fh)); return end if if (fl<0.0_wp) then xl = ua; xh = ub else xl = ub; xh = ua end if u = 0.5_wp*(ua+ub) dxold = abs(ub-ua) dx = dxold call bernstein_eval(u,f,df) do iter = 1_ip, max_iter if (((u-xh)*df-f)*((u-xl)*df-f)>0.0_wp .or. abs(2.0_wp*f)>abs(dxold*df)) then dxold = dx dx = 0.5_wp*(xh-xl) u = xl + dx if (xl==u) exit else dxold = dx dx = f/df temp = u u = u - dx if (temp==u) exit end if if (abs(dx)*h<=2.0_wp*epsilon(1.0_wp)*abs(t(l)+h*u)) exit call bernstein_eval(u,f,df) if (f==0.0_wp) exit if (f<0.0_wp) then xl = u else xh = u end if end do end function newton pure subroutine bernstein_eval(u,f,df) !! Value and derivative of the piece at `u` !! (from the Bernstein coefficients, by de Casteljau's algorithm). real(wp),intent(in) :: u !! the point, on \( u \in [0,1] \) real(wp),intent(out) :: f !! value of the piece real(wp),intent(out) :: df !! derivative of the piece with respect to `u` real(wp),dimension(0:m) :: w !! de Casteljau triangle integer(ip) :: r !! level of the triangle integer(ip) :: jj !! counter w = b do r = 1_ip, m-1_ip do jj = 0_ip, m-r w(jj) = (1.0_wp-u)*w(jj) + u*w(jj+1_ip) end do end do ! the last level gives the value, and its two inputs the derivative df = real(m,wp)*(w(1)-w(0)) f = (1.0_wp-u)*w(0) + u*w(1) end subroutine bernstein_eval end subroutine spline_roots !***************************************************************************************** !***************************************************************************************** !> ! Returns true if `x` is inside a region where the spline is equal ! to `a` (to within `ftol`). The ends of such a region are not inside. ! Used by [[db1root]]. pure function in_flat_region(t,c,n,k,a,ftol,x) result(inside) implicit none integer(ip),intent(in) :: n !! number of b-spline coefficients integer(ip),intent(in) :: k !! order of the b-spline real(wp),dimension(n+k),intent(in) :: t !! knot array real(wp),dimension(n),intent(in) :: c !! b-spline coefficient array real(wp),intent(in) :: a !! the value to solve for real(wp),intent(in) :: ftol !! tolerance on \( |s(x)-a| \) real(wp),intent(in) :: x !! the point to check logical :: inside !! true if `x` is inside a region where !! \( s(x) = a \) (to within `ftol`) integer(ip) :: l !! knot interval containing `x`: `t(l) <= x < t(l+1)` integer(ip) :: j !! previous nonempty knot interval integer(ip) :: ilo !! initial guess for [[dintrv]] integer(ip) :: mflag !! status flag from [[dintrv]] (not used: `x` is in the domain) inside = .false. if (x<=t(k) .or. x>=t(n+1_ip)) return ! knot interval containing x: t(l) <= x < t(l+1) ilo = 1_ip call dintrv(t,n+k,x,ilo,l,mflag) l = min(max(l,k),n) inside = flat(l) if (inside .and. x==t(l)) then ! at a knot: also check the previous (nonempty) interval j = l - 1_ip do while (j>=k) if (t(j)<t(j+1_ip)) exit j = j - 1_ip end do inside = j>=k if (inside) inside = flat(j) end if contains pure function flat(i) !! True if the spline is equal to `a` (to within `ftol`) on knot !! interval `i`, which is the case if all of the `k` b-spline !! coefficients that are nonzero on it are. integer(ip),intent(in) :: i !! knot interval index: `t(i) <= x < t(i+1)` logical :: flat !! true if \( s(x) = a \) on the interval flat = maxval(abs(c(i-k+1_ip:i)-a))<=ftol end function flat end function in_flat_region !***************************************************************************************** !***************************************************************************************** !> ! Tolerance for removing duplicate roots in [[db1root]]: two roots ! closer than this are the same root (found twice, e.g. at a knot). ! ! It is relative to the width of the domain (the resolution of the ! roots found in the knot intervals), plus one unit in the last place ! of the coordinates. It is not relative to the coordinates ! themselves, which would merge distinct roots for a narrow domain ! far from zero. pure function root_dup_tol(x1,x2) result(tol) implicit none real(wp),intent(in) :: x1 !! left end of the domain: `t(k)` real(wp),intent(in) :: x2 !! right end of the domain: `t(n+1)` real(wp) :: tol !! the duplicate tolerance ! (the domain width is scaled before the subtraction, so it does not overflow) tol = (root_xtol*x2 - root_xtol*x1) + spacing(max(abs(x1),abs(x2))) end function root_dup_tol !***************************************************************************************** !***************************************************************************************** !> ! Sort an array in increasing order, and remove values that ! are within `tol` of the previous one. pure subroutine sort_unique(x,tol) implicit none real(wp),dimension(:),allocatable,intent(inout) :: x !! the array real(wp),intent(in) :: tol !! duplicate tolerance integer(ip) :: i !! counter integer(ip) :: j !! counter integer(ip) :: nu !! number of unique values real(wp) :: tmp !! the value being inserted ! insertion sort (the arrays are small and nearly sorted) do i = 2_ip, size(x,kind=ip) tmp = x(i) j = i - 1_ip do while (j>=1_ip) if (x(j)<=tmp) exit x(j+1_ip) = x(j) j = j - 1_ip end do x(j+1_ip) = tmp end do nu = min(1_ip,size(x,kind=ip)) do i = 2_ip, size(x,kind=ip) if (x(i)-x(nu)>tol) then nu = nu + 1_ip x(nu) = x(i) end if end do x = x(1_ip:nu) end subroutine sort_unique !***************************************************************************************** !***************************************************************************************** !> ! Determines the parameters of a function that interpolates ! the two-dimensional gridded data ! $$ [x(i),y(j),\mathrm{fcn}(i,j)] ~\mathrm{for}~ i=1,..,n_x ~\mathrm{and}~ j=1,..,n_y $$ ! The interpolating function and its derivatives may ! subsequently be evaluated by the function [[db2val]]. ! ! The interpolating function is a piecewise polynomial function ! represented as a tensor product of one-dimensional b-splines. the ! form of this function is ! ! $$ s(x,y) = \sum_{i=1}^{n_x} \sum_{j=1}^{n_y} a_{ij} u_i(x) v_j(y) $$ ! ! where the functions \(u_i\) and \(v_j\) are one-dimensional b-spline ! basis functions. the coefficients \( a_{ij} \) are chosen so that ! ! $$ s(x(i),y(j)) = \mathrm{fcn}(i,j) ~\mathrm{for}~ i=1,..,n_x ~\mathrm{and}~ j=1,..,n_y $$ ! ! Note that for each fixed value of \(y\), \( s(x,y) \) is a piecewise ! polynomial function of \(x\) alone, and for each fixed value of \(x\), \( s(x,y) \) ! is a piecewise polynomial function of \(y\) alone. in one dimension ! a piecewise polynomial may be created by partitioning a given ! interval into subintervals and defining a distinct polynomial piece ! on each one. the points where adjacent subintervals meet are called ! knots. each of the functions \(u_i\) and \(v_j\) above is a piecewise ! polynomial. ! ! Users of [[db2ink]] choose the order (degree+1) of the polynomial ! pieces used to define the piecewise polynomial in each of the \(x\) and ! \(y\) directions (`kx` and `ky`). users also may define their own knot ! sequence in \(x\) and \(y\) separately (`tx` and `ty`). if `iflag=0`, however, ! [[db2ink]] will choose sequences of knots that result in a piecewise ! polynomial interpolant with `kx-2` continuous partial derivatives in ! \(x\) and `ky-2` continuous partial derivatives in \(y\). (`kx` knots are taken ! near each endpoint in the \(x\) direction, not-a-knot end conditions ! are used, and the remaining knots are placed at data points if `kx` ! is even or at midpoints between data points if `kx` is odd. the \(y\) ! direction is treated similarly.) ! ! After a call to [[db2ink]], all information necessary to define the ! interpolating function are contained in the parameters `nx`, `ny`, `kx`, ! `ky`, `tx`, `ty`, and `bcoef`. These quantities should not be altered until ! after the last call of the evaluation routine [[db2val]]. ! !### History ! * Boisvert, Ronald, NBS : 25 may 1982 : Author of original routine. ! * JEC : 000330 modified array declarations. ! * Jacob Williams, 2/24/2015 : extensive refactoring of CMLIB routine. pure subroutine db2ink_default(x,nx,y,ny,fcn,kx,ky,iknot,tx,ty,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! Number of \(x\) abcissae integer(ip),intent(in) :: ny !! Number of \(y\) abcissae integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) !! ( \( 2 \le k_x < n_x \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) !! ( \( 2 \le k_y < n_y \) ) !! (order = polynomial degree + 1) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. Must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. Must be strictly increasing. real(wp),dimension(:,:),intent(in) :: fcn !! `(nx,ny)` matrix of function values to interpolate. !! `fcn(i,j)` should contain the function value at the !! point (`x(i)`,`y(j)`) integer(ip),intent(in) :: iknot !! knot sequence flag: !! !! * 0 = knot sequence chosen by [[db1ink]]. !! * 1 = knot sequence chosen by user. real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db2ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db2ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:,:),intent(out) :: bcoef !! `(nx,ny)` matrix of coefficients of the b-spline interpolant. integer(ip),intent(out) :: iflag !! * 0 = successful execution. !! * 2 = `iknot` out of range. !! * 3 = `nx` out of range. !! * 4 = `kx` out of range. !! * 5 = `x` not strictly increasing. !! * 6 = `tx` not non-decreasing. !! * 7 = `ny` out of range. !! * 8 = `ky` out of range. !! * 9 = `y` not strictly increasing. !! * 10 = `ty` not non-decreasing. !! * 700 = `size(x)` \( \ne \) `size(fcn,1)` !! * 701 = `size(y)` \( \ne \) `size(fcn,2)` !! * 706 = `size(x)` \( \ne \) `nx` !! * 707 = `size(y)` \( \ne \) `ny` !! * 712 = `size(tx)` \( \ne \) `nx+kx` !! * 713 = `size(ty)` \( \ne \) `ny+ky` !! * 800 = `size(x)` \( \ne \) `size(bcoef,1)` !! * 801 = `size(y)` \( \ne \) `size(bcoef,2)` logical :: status_ok real(wp),dimension(:),allocatable :: temp !! work array of length `nx*ny` real(wp),dimension(:),allocatable :: work !! work array of length `max(2*kx*(nx+1),2*ky*(ny+1))` !check validity of inputs call check_inputs( iknot,& iflag,& nx=nx,ny=ny,& kx=kx,ky=ky,& x=x,y=y,& tx=tx,ty=ty,& f2=fcn,& bcoef2=bcoef,& status_ok=status_ok) if (status_ok) then !choose knots if (iknot == 0_ip) then call dbknot(x,nx,kx,tx) call dbknot(y,ny,ky,ty) end if allocate(temp(nx*ny)) allocate(work(max(2_ip*kx*(nx+1_ip),2_ip*ky*(ny+1_ip)))) !construct b-spline coefficients call dbtpcf(x,nx,fcn, nx,ny,tx,kx,temp, work,iflag) if (iflag==0_ip) call dbtpcf(y,ny,temp,ny,nx,ty,ky,bcoef,work,iflag) deallocate(temp) deallocate(work) end if end subroutine db2ink_default !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the tensor product piecewise polynomial ! interpolant constructed by the routine [[db2ink]] or one of its ! derivatives at the point (`xval`,`yval`). ! ! To evaluate the interpolant ! itself, set `idx=idy=0`, to evaluate the first partial with respect ! to `x`, set `idx=1,idy=0`, and so on. ! ! [[db2val]] returns 0.0 if `(xval,yval)` is out of range. that is, if !```fortran ! xval < tx(1) .or. xval > tx(nx+kx) .or. ! yval < ty(1) .or. yval > ty(ny+ky) !``` ! if the knots tx and ty were chosen by [[db2ink]], then this is equivalent to: !```fortran ! xval < x(1) .or. xval > x(nx)+epsx .or. ! yval < y(1) .or. yval > y(ny)+epsy !``` ! where !```fortran ! epsx = 0.1*(x(nx)-x(nx-1)) ! epsy = 0.1*(y(ny)-y(ny-1)) !``` ! ! The input quantities `tx`, `ty`, `nx`, `ny`, `kx`, `ky`, and `bcoef` should be ! unchanged since the last call of [[db2ink]]. ! !### History ! * Boisvert, Ronald, NBS : 25 may 1982 : Author of original routine. ! * JEC : 000330 modified array declarations. ! * Jacob Williams, 2/24/2015 : extensive refactoring of CMLIB routine. pure subroutine db2val_default(xval,yval,idx,idy,tx,ty,nx,ny,kx,ky,bcoef,f,iflag,inbvx,inbvy,iloy,w1,w0,extrap) implicit none integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). !! (same as in last call to [[db2ink]]) integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). !! (same as in last call to [[db2ink]]) integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). !! (same as in last call to [[db2ink]]) integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). !! (same as in last call to [[db2ink]]) real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),dimension(nx+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. !! (same as in last call to [[db2ink]]) real(wp),dimension(ny+ky),intent(in) :: ty !! sequence of knots defining the piecewise !! polynomial in the \(y\) direction. !! (same as in last call to [[db2ink]]) real(wp),dimension(nx,ny),intent(in) :: bcoef !! the b-spline coefficients computed by [[db2ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be set to 1 !! the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: inbvy !! not used (kept for backward compatibility) integer(ip),intent(inout) :: iloy !! initialization parameter which must be set to 1 !! the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(ky),intent(inout) :: w1 !! work array real(wp),dimension(3_ip*max(kx,ky)),intent(inout) :: w0 !! not used (kept for backward compatibility) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx, lefty !! interval indices integer(ip) :: ix, iy !! coefficient offsets integer(ip) :: j !! counter real(wp),dimension(kx) :: bx !! basis function weights in x real(wp),dimension(ky) :: by !! basis function weights in y f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky ! contract the coefficients one direction at a time do j=1_ip,ky w1(j) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j)) end do f = dot_product(by,w1) end subroutine db2val_default !***************************************************************************************** !***************************************************************************************** !> ! Determines the parameters of a function that interpolates ! the three-dimensional gridded data ! $$ [x(i),y(j),z(k),\mathrm{fcn}(i,j,k)] ~\mathrm{for}~ ! i=1,..,n_x ~\mathrm{and}~ j=1,..,n_y, ~\mathrm{and}~ k=1,..,n_z $$ ! The interpolating function and ! its derivatives may subsequently be evaluated by the function ! [[db3val]]. ! ! The interpolating function is a piecewise polynomial function ! represented as a tensor product of one-dimensional b-splines. the ! form of this function is ! $$ s(x,y,z) = \sum_{i=1}^{n_x} \sum_{j=1}^{n_y} \sum_{k=1}^{n_z} ! a_{ijk} u_i(x) v_j(y) w_k(z) $$ ! ! where the functions \(u_i\), \(v_j\), and \(w_k\) are one-dimensional b- ! spline basis functions. the coefficients \(a_{ijk}\) are chosen so that: ! ! $$ s(x(i),y(j),z(k)) = \mathrm{fcn}(i,j,k) ! ~\mathrm{for}~ i=1,..,n_x , j=1,..,n_y , k=1,..,n_z $$ ! ! Note that for fixed values of \(y\) and \(z\) \(s(x,y,z)\) is a piecewise ! polynomial function of \(x\) alone, for fixed values of \(x\) and \(z\) \(s(x,y,z)\) ! is a piecewise polynomial function of \(y\) alone, and for fixed ! values of \(x\) and \(y\) \(s(x,y,z)\) is a function of \(z\) alone. in one ! dimension a piecewise polynomial may be created by partitioning a ! given interval into subintervals and defining a distinct polynomial ! piece on each one. the points where adjacent subintervals meet are ! called knots. each of the functions \(u_i\), \(v_j\), and \(w_k\) above is a ! piecewise polynomial. ! ! Users of [[db3ink]] choose the order (degree+1) of the polynomial ! pieces used to define the piecewise polynomial in each of the \(x\), \(y\), ! and \(z\) directions (`kx`, `ky`, and `kz`). users also may define their own ! knot sequence in \(x\), \(y\), \(z\) separately (`tx`, `ty`, and `tz`). if `iflag=0`, ! however, [[db3ink]] will choose sequences of knots that result in a ! piecewise polynomial interpolant with `kx-2` continuous partial ! derivatives in \(x\), `ky-2` continuous partial derivatives in \(y\), and `kz-2` ! continuous partial derivatives in \(z\). (`kx` knots are taken near ! each endpoint in \(x\), not-a-knot end conditions are used, and the ! remaining knots are placed at data points if `kx` is even or at ! midpoints between data points if `kx` is odd. the \(y\) and \(z\) directions ! are treated similarly.) ! ! After a call to [[db3ink]], all information necessary to define the ! interpolating function are contained in the parameters `nx`, `ny`, `nz`, ! `kx`, `ky`, `kz`, `tx`, `ty`, `tz`, and `bcoef`. these quantities should not be ! altered until after the last call of the evaluation routine [[db3val]]. ! !### History ! * Boisvert, Ronald, NBS : 25 may 1982 : Author of original routine. ! * JEC : 000330 modified array declarations. ! * Jacob Williams, 2/24/2015 : extensive refactoring of CMLIB routine. pure subroutine db3ink_default(x,nx,y,ny,z,nz,fcn,kx,ky,kz,iknot,tx,ty,tz,bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! number of \(x\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: ny !! number of \(y\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nz !! number of \(z\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: kx !! The order of spline pieces in \(x\) !! ( \( 2 \le k_x < n_x \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: ky !! The order of spline pieces in \(y\) !! ( \( 2 \le k_y < n_y \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: kz !! the order of spline pieces in \(z\) !! ( \( 2 \le k_z < n_z \) ) !! (order = polynomial degree + 1) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. must be strictly increasing. real(wp),dimension(:,:,:),intent(in) :: fcn !! `(nx,ny,nz)` matrix of function values to interpolate. `fcn(i,j,k)` should !! contain the function value at the point (`x(i)`,`y(j)`,`z(k)`) integer(ip),intent(in) :: iknot !! knot sequence flag: !! !! * 0 = knot sequence chosen by [[db3ink]]. !! * 1 = knot sequence chosen by user. real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db3ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db3ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db3ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:,:,:),intent(out) :: bcoef !! `(nx,ny,nz)` matrix of coefficients of the b-spline interpolant. integer(ip),intent(out) :: iflag !! * 0 = successful execution. !! * 2 = `iknot` out of range. !! * 3 = `nx` out of range. !! * 4 = `kx` out of range. !! * 5 = `x` not strictly increasing. !! * 6 = `tx` not non-decreasing. !! * 7 = `ny` out of range. !! * 8 = `ky` out of range. !! * 9 = `y` not strictly increasing. !! * 10 = `ty` not non-decreasing. !! * 11 = `nz` out of range. !! * 12 = `kz` out of range. !! * 13 = `z` not strictly increasing. !! * 14 = `ty` not non-decreasing. !! * 700 = `size(x) ` \(\ne\) `size(fcn,1)` !! * 701 = `size(y) ` \(\ne\) `size(fcn,2)` !! * 702 = `size(z) ` \(\ne\) `size(fcn,3)` !! * 706 = `size(x) ` \(\ne\) `nx` !! * 707 = `size(y) ` \(\ne\) `ny` !! * 708 = `size(z) ` \(\ne\) `nz` !! * 712 = `size(tx)` \(\ne\) `nx+kx` !! * 713 = `size(ty)` \(\ne\) `ny+ky` !! * 714 = `size(tz)` \(\ne\) `nz+kz` !! * 800 = `size(x) ` \(\ne\) `size(bcoef,1)` !! * 801 = `size(y) ` \(\ne\) `size(bcoef,2)` !! * 802 = `size(z) ` \(\ne\) `size(bcoef,3)` logical :: status_ok real(wp),dimension(:),allocatable :: temp !! work array of length `nx*ny*nz` real(wp),dimension(:),allocatable :: work !! work array of length `max(2*kx*(nx+1), !! 2*ky*(ny+1),2*kz*(nz+1))` ! check validity of input call check_inputs( iknot,& iflag,& nx=nx,ny=ny,nz=nz,& kx=kx,ky=ky,kz=kz,& x=x,y=y,z=z,& tx=tx,ty=ty,tz=tz,& f3=fcn,& bcoef3=bcoef,& status_ok=status_ok) if (status_ok) then ! choose knots if (iknot == 0_ip) then call dbknot(x,nx,kx,tx) call dbknot(y,ny,ky,ty) call dbknot(z,nz,kz,tz) end if allocate(temp(nx*ny*nz)) allocate(work(max(2_ip*kx*(nx+1_ip),2_ip*ky*(ny+1_ip),2_ip*kz*(nz+1_ip)))) ! construct b-spline coefficients ! (odd number of passes, so start in bcoef to end up there) call dbtpcf(x,nx,fcn, nx,ny*nz,tx,kx,bcoef,work,iflag) if (iflag==0_ip) call dbtpcf(y,ny,bcoef,ny,nx*nz,ty,ky,temp, work,iflag) if (iflag==0_ip) call dbtpcf(z,nz,temp, nz,nx*ny,tz,kz,bcoef,work,iflag) deallocate(temp) deallocate(work) end if end subroutine db3ink_default !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the tensor product piecewise polynomial ! interpolant constructed by the routine [[db3ink]] or one of its ! derivatives at the point (`xval`,`yval`,`zval`). ! ! To evaluate the ! interpolant itself, set `idx=idy=idz=0`, to evaluate the first ! partial with respect to `x`, set `idx=1`,`idy=idz=0`, and so on. ! ! [[db3val]] returns 0.0 if (`xval`,`yval`,`zval`) is out of range. that is, !```fortran ! xval<tx(1) .or. xval>tx(nx+kx) .or. ! yval<ty(1) .or. yval>ty(ny+ky) .or. ! zval<tz(1) .or. zval>tz(nz+kz) !``` ! if the knots `tx`, `ty`, and `tz` were chosen by [[db3ink]], then this is ! equivalent to !```fortran ! xval<x(1) .or. xval>x(nx)+epsx .or. ! yval<y(1) .or. yval>y(ny)+epsy .or. ! zval<z(1) .or. zval>z(nz)+epsz !``` ! where !```fortran ! epsx = 0.1*(x(nx)-x(nx-1)) ! epsy = 0.1*(y(ny)-y(ny-1)) ! epsz = 0.1*(z(nz)-z(nz-1)) !``` ! ! The input quantities `tx`, `ty`, `tz`, `nx`, `ny`, `nz`, `kx`, `ky`, `kz`, and `bcoef` ! should remain unchanged since the last call of [[db3ink]]. ! !### History ! * Boisvert, Ronald, NBS : 25 may 1982 : Author of original routine. ! * JEC : 000330 modified array declarations. ! * Jacob Williams, 2/24/2015 : extensive refactoring of CMLIB routine. pure subroutine db3val_default(xval,yval,zval,idx,idy,idz,& tx,ty,tz,& nx,ny,nz,kx,ky,kz,bcoef,f,iflag,& inbvx,inbvy,inbvz,iloy,iloz,w2,w1,w0,extrap) implicit none integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). !! (same as in last call to [[db3ink]]) integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). !! (same as in last call to [[db3ink]]) integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). !! (same as in last call to [[db3ink]]) integer(ip),intent(in) :: kx !! order of polynomial pieces in \(z\). !! (same as in last call to [[db3ink]]) integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). !! (same as in last call to [[db3ink]]) integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). !! (same as in last call to [[db3ink]]) real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),dimension(nx+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. (same as in last call to [[db3ink]]) real(wp),dimension(ny+ky),intent(in) :: ty !! sequence of knots defining the piecewise polynomial !! in the \(y\) direction. (same as in last call to [[db3ink]]) real(wp),dimension(nz+kz),intent(in) :: tz !! sequence of knots defining the piecewise polynomial !! in the \(z\) direction. (same as in last call to [[db3ink]]) real(wp),dimension(nx,ny,nz),intent(in) :: bcoef !! the b-spline coefficients computed by [[db3ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: inbvy !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvz !! not used (kept for backward compatibility) integer(ip),intent(inout) :: iloy !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be !! set to 1 the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(ky,kz),intent(inout) :: w2 !! work array real(wp),dimension(kz),intent(inout) :: w1 !! work array real(wp),dimension(3_ip*max(kx,ky,kz)),intent(inout) :: w0 !! not used (kept for backward compatibility) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx, lefty, leftz !! interval indices integer(ip) :: ix, iy, iz !! coefficient offsets integer(ip) :: j, k !! counters real(wp),dimension(kx) :: bx !! basis function weights in x real(wp),dimension(ky) :: by !! basis function weights in y real(wp),dimension(kz) :: bz !! basis function weights in z f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz ! contract the coefficients one direction at a time do k=1_ip,kz do j=1_ip,ky w2(j,k) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k)) end do w1(k) = dot_product(by,w2(:,k)) end do f = dot_product(bz,w1) end subroutine db3val_default !***************************************************************************************** !***************************************************************************************** !> ! Determines the parameters of a function that interpolates ! the four-dimensional gridded data ! $$ [x(i),y(j),z(k),q(l),\mathrm{fcn}(i,j,k,l)] ~\mathrm{for}~ ! i=1,..,n_x ~\mathrm{and}~ j=1,..,n_y, ~\mathrm{and}~ k=1,..,n_z, ! ~\mathrm{and}~ l=1,..,n_q $$ ! The interpolating function and its derivatives may ! subsequently be evaluated by the function [[db4val]]. ! ! See [[db3ink]] header for more details. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine db4ink_default(x,nx,y,ny,z,nz,q,nq,& fcn,& kx,ky,kz,kq,& iknot,& tx,ty,tz,tq,& bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! number of \(x\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: ny !! number of \(y\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nz !! number of \(z\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nq !! number of \(q\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: kx !! the order of spline pieces in \(x\) !! ( \( 2 \le k_x < n_x \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: ky !! the order of spline pieces in \(y\) !! ( \( 2 \le k_y < n_y \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: kz !! the order of spline pieces in \(z\) !! ( \( 2 \le k_z < n_z \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: kq !! the order of spline pieces in \(q\) !! ( \( 2 \le k_q < n_q \) ). !! (order = polynomial degree + 1) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: q !! `(nq)` array of \(q\) abcissae. must be strictly increasing. real(wp),dimension(:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nq)` matrix of function values to interpolate. !! `fcn(i,j,k,q)` should contain the function value at the !! point (`x(i)`,`y(j)`,`z(k)`,`q(l)`) integer(ip),intent(in) :: iknot !! knot sequence flag: !! !! * 0 = knot sequence chosen by [[db4ink]]. !! * 1 = knot sequence chosen by user. real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the x direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db4ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the y direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db4ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the z direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db4ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tq !! The `(nq+kq)` knots in the q direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db4ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nq)` matrix of coefficients of the b-spline !! interpolant. integer(ip),intent(out) :: iflag !! * 0 = successful execution. !! * 2 = `iknot` out of range. !! * 3 = `nx` out of range. !! * 4 = `kx` out of range. !! * 5 = `x` not strictly increasing. !! * 6 = `tx` not non-decreasing. !! * 7 = `ny` out of range. !! * 8 = `ky` out of range. !! * 9 = `y` not strictly increasing. !! * 10 = `ty` not non-decreasing. !! * 11 = `nz` out of range. !! * 12 = `kz` out of range. !! * 13 = `z` not strictly increasing. !! * 14 = `tz` not non-decreasing. !! * 15 = `nq` out of range. !! * 16 = `kq` out of range. !! * 17 = `q` not strictly increasing. !! * 18 = `tq` not non-decreasing. !! * 700 = `size(x)` \( \ne \) `size(fcn,1)` !! * 701 = `size(y)` \( \ne \) `size(fcn,2)` !! * 702 = `size(z)` \( \ne \) `size(fcn,3)` !! * 703 = `size(q)` \( \ne \) `size(fcn,4)` !! * 706 = `size(x)` \( \ne \) `nx` !! * 707 = `size(y)` \( \ne \) `ny` !! * 708 = `size(z)` \( \ne \) `nz` !! * 709 = `size(q)` \( \ne \) `nq` !! * 712 = `size(tx`) \( \ne \) `nx+kx` !! * 713 = `size(ty`) \( \ne \) `ny+ky` !! * 714 = `size(tz`) \( \ne \) `nz+kz` !! * 715 = `size(tq`) \( \ne \) `nq+kq` !! * 800 = `size(x)` \( \ne \) `size(bcoef,1)` !! * 801 = `size(y)` \( \ne \) `size(bcoef,2)` !! * 802 = `size(z)` \( \ne \) `size(bcoef,3)` !! * 803 = `size(q)` \( \ne \) `size(bcoef,4)` logical :: status_ok real(wp),dimension(:),allocatable :: temp !! work array of dimension `nx*ny*nz*nq` real(wp),dimension(:),allocatable :: work !! work array of dimension `max(2*kx*(nx+1), !! 2*ky*(ny+1),2*kz*(nz+1),2*kq*(nq+1))` ! check validity of input call check_inputs( iknot,& iflag,& nx=nx,ny=ny,nz=nz,nq=nq,& kx=kx,ky=ky,kz=kz,kq=kq,& x=x,y=y,z=z,q=q,& tx=tx,ty=ty,tz=tz,tq=tq,& f4=fcn,& bcoef4=bcoef,& status_ok=status_ok) if (status_ok) then ! choose knots if (iknot == 0_ip) then call dbknot(x,nx,kx,tx) call dbknot(y,ny,ky,ty) call dbknot(z,nz,kz,tz) call dbknot(q,nq,kq,tq) end if allocate(temp(nx*ny*nz*nq)) allocate(work(max(2_ip*kx*(nx+1_ip),2_ip*ky*(ny+1_ip),2_ip*kz*(nz+1_ip),2_ip*kq*(nq+1_ip)))) ! construct b-spline coefficients call dbtpcf(x,nx,fcn, nx,ny*nz*nq,tx,kx,temp, work,iflag) if (iflag==0_ip) call dbtpcf(y,ny,temp, ny,nx*nz*nq,ty,ky,bcoef,work,iflag) if (iflag==0_ip) call dbtpcf(z,nz,bcoef,nz,nx*ny*nq,tz,kz,temp, work,iflag) if (iflag==0_ip) call dbtpcf(q,nq,temp, nq,nx*ny*nz,tq,kq,bcoef,work,iflag) deallocate(temp) deallocate(work) end if end subroutine db4ink_default !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the tensor product piecewise polynomial ! interpolant constructed by the routine [[db4ink]] or one of its ! derivatives at the point (`xval`,`yval`,`zval`,`qval`). ! ! To evaluate the ! interpolant itself, set `idx=idy=idz=idq=0`, to evaluate the first ! partial with respect to `x`, set `idx=1,idy=idz=idq=0`, and so on. ! ! See [[db3val]] header for more information. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine db4val_default(xval,yval,zval,qval,& idx,idy,idz,idq,& tx,ty,tz,tq,& nx,ny,nz,nq,& kx,ky,kz,kq,& bcoef,f,iflag,& inbvx,inbvy,inbvz,inbvq,& iloy,iloz,iloq,w3,w2,w1,w0,extrap) implicit none integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idq !! \(q\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: nq !! the number of interpolation points in \(q\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). !! (same as in last call to [[db4ink]]) integer(ip),intent(in) :: kq !! order of polynomial pieces in \(q\). !! (same as in last call to [[db4ink]]) real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),intent(in) :: qval !! \(q\) coordinate of evaluation point. real(wp),dimension(nx+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. (same as in last call to !! [[db4ink]]) real(wp),dimension(ny+ky),intent(in) :: ty !! sequence of knots defining the piecewise polynomial !! in the \(y\) direction. (same as in last call to !! [[db4ink]]) real(wp),dimension(nz+kz),intent(in) :: tz !! sequence of knots defining the piecewise polynomial !! in the \(z\) direction. (same as in last call to !! [[db4ink]]) real(wp),dimension(nq+kq),intent(in) :: tq !! sequence of knots defining the piecewise polynomial !! in the \(q\) direction. (same as in last call to !! [[db4ink]]) real(wp),dimension(nx,ny,nz,nq),intent(in) :: bcoef !! the b-spline coefficients computed by [[db4ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: inbvy !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvz !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvq !! not used (kept for backward compatibility) integer(ip),intent(inout) :: iloy !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloq !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(ky,kz,kq),intent(inout) :: w3 !! work array real(wp),dimension(kz,kq),intent(inout) :: w2 !! work array real(wp),dimension(kq),intent(inout) :: w1 !! work array real(wp),dimension(3_ip*max(kx,ky,kz,kq)),intent(inout) :: w0 !! not used (kept for backward compatibility) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx, lefty, leftz, leftq !! interval indices integer(ip) :: ix, iy, iz, iq !! coefficient offsets integer(ip) :: j, k, q !! counters real(wp),dimension(kx) :: bx !! basis function weights in x real(wp),dimension(ky) :: by !! basis function weights in y real(wp),dimension(kz) :: bz !! basis function weights in z real(wp),dimension(kq) :: bq !! basis function weights in q f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return iflag = check_value(qval,tq,4_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tq,nq,kq,idq,qval,iloq,leftq,bq,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz iq = leftq - kq ! contract the coefficients one direction at a time do q=1_ip,kq do k=1_ip,kz do j=1_ip,ky w3(j,k,q) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,iq+q)) end do w2(k,q) = dot_product(by,w3(:,k,q)) end do w1(q) = dot_product(bz,w2(:,q)) end do f = dot_product(bq,w1) end subroutine db4val_default !***************************************************************************************** !***************************************************************************************** !> ! Determines the parameters of a function that interpolates ! the five-dimensional gridded data: ! ! $$ [x(i),y(j),z(k),q(l),r(m),\mathrm{fcn}(i,j,k,l,m)] $$ ! ! for: ! ! $$ i=1,..,n_x ~\mathrm{and}~ j=1,..,n_y, ~\mathrm{and}~ k=1,..,n_z, ! ~\mathrm{and}~ l=1,..,n_q, ~\mathrm{and}~ m=1,..,n_r $$ ! ! The interpolating function and its derivatives may subsequently be evaluated ! by the function [[db5val]]. ! ! See [[db3ink]] header for more details. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine db5ink_default(x,nx,y,ny,z,nz,q,nq,r,nr,& fcn,& kx,ky,kz,kq,kr,& iknot,& tx,ty,tz,tq,tr,& bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! number of \(x\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: ny !! number of \(y\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nz !! number of \(z\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nq !! number of \(q\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nr !! number of \(r\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: kx !! the order of spline pieces in \(x\) !! ( \( 2 \le k_x < n_x \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: ky !! the order of spline pieces in \(y\) !! ( \( 2 \le k_y < n_y \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: kz !! the order of spline pieces in \(z\) !! ( \( 2 \le k_z < n_z \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: kq !! the order of spline pieces in \(q\) !! ( \( 2 \le k_q < n_q \) ). !! (order = polynomial degree + 1) integer(ip),intent(in) :: kr !! the order of spline pieces in \(r\) !! ( \( 2 \le k_r < n_r \) ). !! (order = polynomial degree + 1) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: q !! `(nq)` array of \(q\) abcissae. must be strictly increasing. real(wp),dimension(:),intent(in) :: r !! `(nr)` array of \(r\) abcissae. must be strictly increasing. real(wp),dimension(:,:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nq,nr)` matrix of function values to interpolate. !! `fcn(i,j,k,q,r)` should contain the function value at the !! point (`x(i)`,`y(j)`,`z(k)`,`q(l)`,`r(m)`) integer(ip),intent(in) :: iknot !! knot sequence flag: !! !! * 0 = knot sequence chosen by [[db5ink]]. !! * 1 = knot sequence chosen by user. real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db5ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db5ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db5ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tq !! The `(nq+kq)` knots in the \(q\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db5ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tr !! The `(nr+kr)` knots in the \(r\) direction for the spline !! interpolant. !! !! * If `iknot=0` these are chosen by [[db5ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:,:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nq,nr)` matrix of coefficients of the b-spline !! interpolant. integer(ip),intent(out) :: iflag !! * 0 = successful execution. !! * 2 = `iknot` out of range. !! * 3 = `nx` out of range. !! * 4 = `kx` out of range. !! * 5 = `x` not strictly increasing. !! * 6 = `tx` not non-decreasing. !! * 7 = `ny` out of range. !! * 8 = `ky` out of range. !! * 9 = `y` not strictly increasing. !! * 10 = `ty` not non-decreasing. !! * 11 = `nz` out of range. !! * 12 = `kz` out of range. !! * 13 = `z` not strictly increasing. !! * 14 = `tz` not non-decreasing. !! * 15 = `nq` out of range. !! * 16 = `kq` out of range. !! * 17 = `q` not strictly increasing. !! * 18 = `tq` not non-decreasing. !! * 19 = `nr` out of range. !! * 20 = `kr` out of range. !! * 21 = `r` not strictly increasing. !! * 22 = `tr` not non-decreasing. !! * 700 = `size(x)` \( \ne \) `size(fcn,1)` !! * 701 = `size(y)` \( \ne \) `size(fcn,2)` !! * 702 = `size(z)` \( \ne \) `size(fcn,3)` !! * 703 = `size(q)` \( \ne \) `size(fcn,4)` !! * 704 = `size(r)` \( \ne \) `size(fcn,5)` !! * 706 = `size(x)` \( \ne \) `nx` !! * 707 = `size(y)` \( \ne \) `ny` !! * 708 = `size(z)` \( \ne \) `nz` !! * 709 = `size(q)` \( \ne \) `nq` !! * 710 = `size(r)` \( \ne \) `nr` !! * 712 = `size(tx)` \( \ne \) `nx+kx` !! * 713 = `size(ty)` \( \ne \) `ny+ky` !! * 714 = `size(tz)` \( \ne \) `nz+kz` !! * 715 = `size(tq)` \( \ne \) `nq+kq` !! * 716 = `size(tr)` \( \ne \) `nr+kr` !! * 800 = `size(x)` \( \ne \) `size(bcoef,1)` !! * 801 = `size(y)` \( \ne \) `size(bcoef,2)` !! * 802 = `size(z)` \( \ne \) `size(bcoef,3)` !! * 803 = `size(q)` \( \ne \) `size(bcoef,4)` !! * 804 = `size(r)` \( \ne \) `size(bcoef,5)` logical :: status_ok real(wp),dimension(:),allocatable :: temp !! work array of length `nx*ny*nz*nq*nr` real(wp),dimension(:),allocatable :: work !! work array of length `max(2*kx*(nx+1), !! 2*ky*(ny+1),2*kz*(nz+1),2*kq*(nq+1),2*kr*(nr+1))` ! check validity of input call check_inputs( iknot,& iflag,& nx=nx,ny=ny,nz=nz,nq=nq,nr=nr,& kx=kx,ky=ky,kz=kz,kq=kq,kr=kr,& x=x,y=y,z=z,q=q,r=r,& tx=tx,ty=ty,tz=tz,tq=tq,tr=tr,& f5=fcn,& bcoef5=bcoef,& status_ok=status_ok) if (status_ok) then ! choose knots if (iknot == 0_ip) then call dbknot(x,nx,kx,tx) call dbknot(y,ny,ky,ty) call dbknot(z,nz,kz,tz) call dbknot(q,nq,kq,tq) call dbknot(r,nr,kr,tr) end if allocate(temp(nx*ny*nz*nq*nr)) allocate(work(max(2_ip*kx*(nx+1_ip),2_ip*ky*(ny+1_ip),2_ip*kz*(nz+1_ip),2_ip*kq*(nq+1_ip),2_ip*kr*(nr+1_ip)))) ! construct b-spline coefficients ! (odd number of passes, so start in bcoef to end up there) call dbtpcf(x,nx,fcn, nx,ny*nz*nq*nr,tx,kx,bcoef,work,iflag) if (iflag==0_ip) call dbtpcf(y,ny,bcoef, ny,nx*nz*nq*nr,ty,ky,temp, work,iflag) if (iflag==0_ip) call dbtpcf(z,nz,temp, nz,nx*ny*nq*nr,tz,kz,bcoef,work,iflag) if (iflag==0_ip) call dbtpcf(q,nq,bcoef, nq,nx*ny*nz*nr,tq,kq,temp, work,iflag) if (iflag==0_ip) call dbtpcf(r,nr,temp, nr,nx*ny*nz*nq,tr,kr,bcoef,work,iflag) deallocate(temp) deallocate(work) end if end subroutine db5ink_default !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the tensor product piecewise polynomial ! interpolant constructed by the routine [[db5ink]] or one of its ! derivatives at the point (`xval`,`yval`,`zval`,`qval`,`rval`). ! ! To evaluate the ! interpolant itself, set `idx=idy=idz=idq=idr=0`, to evaluate the first ! partial with respect to `x`, set `idx=1,idy=idz=idq=idr=0,` and so on. ! ! See [[db3val]] header for more information. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine db5val_default(xval,yval,zval,qval,rval,& idx,idy,idz,idq,idr,& tx,ty,tz,tq,tr,& nx,ny,nz,nq,nr,& kx,ky,kz,kq,kr,& bcoef,f,iflag,& inbvx,inbvy,inbvz,inbvq,inbvr,& iloy,iloz,iloq,ilor,& w4,w3,w2,w1,w0,extrap) implicit none integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idq !! \(q\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idr !! \(r\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: nq !! the number of interpolation points in \(q\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: nr !! the number of interpolation points in \(r\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: kq !! order of polynomial pieces in \(q\). !! (same as in last call to [[db5ink]]) integer(ip),intent(in) :: kr !! order of polynomial pieces in \(r\). !! (same as in last call to [[db5ink]]) real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),intent(in) :: qval !! \(q\) coordinate of evaluation point. real(wp),intent(in) :: rval !! \(r\) coordinate of evaluation point. real(wp),dimension(nx+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. !! (same as in last call to [[db5ink]]) real(wp),dimension(ny+ky),intent(in) :: ty !! sequence of knots defining the piecewise polynomial !! in the \(y\) direction. !! (same as in last call to [[db5ink]]) real(wp),dimension(nz+kz),intent(in) :: tz !! sequence of knots defining the piecewise polynomial !! in the \(z\) direction. !! (same as in last call to [[db5ink]]) real(wp),dimension(nq+kq),intent(in) :: tq !! sequence of knots defining the piecewise polynomial !! in the \(q\) direction. !! (same as in last call to [[db5ink]]) real(wp),dimension(nr+kr),intent(in) :: tr !! sequence of knots defining the piecewise polynomial !! in the \(r\) direction. !! (same as in last call to [[db5ink]]) real(wp),dimension(nx,ny,nz,nq,nr),intent(in) :: bcoef !! the b-spline coefficients computed by [[db5ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: inbvy !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvz !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvq !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvr !! not used (kept for backward compatibility) integer(ip),intent(inout) :: iloy !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloq !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: ilor !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(ky,kz,kq,kr),intent(inout) :: w4 !! work array real(wp),dimension(kz,kq,kr),intent(inout) :: w3 !! work array real(wp),dimension(kq,kr),intent(inout) :: w2 !! work array real(wp),dimension(kr),intent(inout) :: w1 !! work array real(wp),dimension(3_ip*max(kx,ky,kz,kq,kr)),intent(inout) :: w0 !! not used (kept for backward compatibility) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx, lefty, leftz, leftq, leftr !! interval indices integer(ip) :: ix, iy, iz, iq, ir !! coefficient offsets integer(ip) :: j, k, q, r !! counters real(wp),dimension(kx) :: bx !! basis function weights in x real(wp),dimension(ky) :: by !! basis function weights in y real(wp),dimension(kz) :: bz !! basis function weights in z real(wp),dimension(kq) :: bq !! basis function weights in q real(wp),dimension(kr) :: br !! basis function weights in r f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return iflag = check_value(qval,tq,4_ip,extrap); if (iflag/=0_ip) return iflag = check_value(rval,tr,5_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tq,nq,kq,idq,qval,iloq,leftq,bq,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tr,nr,kr,idr,rval,ilor,leftr,br,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz iq = leftq - kq ir = leftr - kr ! contract the coefficients one direction at a time do r=1_ip,kr do q=1_ip,kq do k=1_ip,kz do j=1_ip,ky w4(j,k,q,r) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,iq+q,ir+r)) end do w3(k,q,r) = dot_product(by,w4(:,k,q,r)) end do w2(q,r) = dot_product(bz,w3(:,q,r)) end do w1(r) = dot_product(bq,w2(:,r)) end do f = dot_product(br,w1) end subroutine db5val_default !***************************************************************************************** !***************************************************************************************** !> ! Determines the parameters of a function that interpolates ! the six-dimensional gridded data: ! ! $$ [x(i),y(j),z(k),q(l),r(m),s(n),\mathrm{fcn}(i,j,k,l,m,n)] $$ ! ! for: ! ! $$ i=1,..,n_x, j=1,..,n_y, k=1,..,n_z, l=1,..,n_q, m=1,..,n_r, n=1,..,n_s $$ ! ! the interpolating function and its derivatives may subsequently be evaluated ! by the function [[db6val]]. ! ! See [[db3ink]] header for more details. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine db6ink_default(x,nx,y,ny,z,nz,q,nq,r,nr,s,ns,& fcn,& kx,ky,kz,kq,kr,ks,& iknot,& tx,ty,tz,tq,tr,ts,& bcoef,iflag) implicit none integer(ip),intent(in) :: nx !! number of \(x\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: ny !! number of \(y\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nz !! number of \(z\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nq !! number of \(q\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: nr !! number of \(r\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: ns !! number of \(s\) abcissae ( \( \ge 3 \) ) integer(ip),intent(in) :: kx !! the order of spline pieces in \(x\) !! ( \( 2 \le k_x < n_x \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: ky !! the order of spline pieces in \(y\) !! ( \( 2 \le k_y < n_y \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: kz !! the order of spline pieces in \(z\) !! ( \( 2 \le k_z < n_z \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: kq !! the order of spline pieces in \(q\) !! ( \( 2 \le k_q < n_q \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: kr !! the order of spline pieces in \(r\) !! ( \( 2 \le k_r < n_r \) ) !! (order = polynomial degree + 1) integer(ip),intent(in) :: ks !! the order of spline pieces in \(s\) !! ( \( 2 \le k_s < n_s \) ) !! (order = polynomial degree + 1) real(wp),dimension(:),intent(in) :: x !! `(nx)` array of \(x\) abcissae. !! must be strictly increasing. real(wp),dimension(:),intent(in) :: y !! `(ny)` array of \(y\) abcissae. !! must be strictly increasing. real(wp),dimension(:),intent(in) :: z !! `(nz)` array of \(z\) abcissae. !! must be strictly increasing. real(wp),dimension(:),intent(in) :: q !! `(nq)` array of \(q\) abcissae. !! must be strictly increasing. real(wp),dimension(:),intent(in) :: r !! `(nr)` array of \(r\) abcissae. !! must be strictly increasing. real(wp),dimension(:),intent(in) :: s !! `(ns)` array of \(s\) abcissae. !! must be strictly increasing. real(wp),dimension(:,:,:,:,:,:),intent(in) :: fcn !! `(nx,ny,nz,nq,nr,ns)` matrix of function values to !! interpolate. `fcn(i,j,k,q,r,s)` should contain the !! function value at the point !! (`x(i)`,`y(j)`,`z(k)`,`q(l)`,`r(m)`,`s(n)`) integer(ip),intent(in) :: iknot !! knot sequence flag: !! !! * 0 = knot sequence chosen by [[db6ink]]. !! * 1 = knot sequence chosen by user. real(wp),dimension(:),intent(inout) :: tx !! The `(nx+kx)` knots in the \(x\) direction for the !! spline interpolant. !! !! * f `iknot=0` these are chosen by [[db6ink]]. !! * f `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: ty !! The `(ny+ky)` knots in the \(y\) direction for the !! spline interpolant. !! !! * If `iknot=0` these are chosen by [[db6ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tz !! The `(nz+kz)` knots in the \(z\) direction for the !! spline interpolant. !! !! * If `iknot=0` these are chosen by [[db6ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tq !! The `(nq+kq)` knots in the \(q\) direction for the !! spline interpolant. !! !! * If `iknot=0` these are chosen by [[db6ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: tr !! The `(nr+kr)` knots in the \(r\) direction for the !! spline interpolant. !! !! * If `iknot=0` these are chosen by [[db6ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:),intent(inout) :: ts !! The `(ns+ks)` knots in the \(s\) direction for the !! spline interpolant. !! !! * If `iknot=0` these are chosen by [[db6ink]]. !! * If `iknot=1` these are specified by the user. !! !! Must be non-decreasing. real(wp),dimension(:,:,:,:,:,:),intent(out) :: bcoef !! `(nx,ny,nz,nq,nr,ns)` matrix of coefficients of the !! b-spline interpolant. integer(ip),intent(out) :: iflag !! * 0 = successful execution. !! * 2 = `iknot` out of range. !! * 3 = `nx` out of range. !! * 4 = `kx` out of range. !! * 5 = `x` not strictly increasing. !! * 6 = `tx` not non-decreasing. !! * 7 = `ny` out of range. !! * 8 = `ky` out of range. !! * 9 = `y` not strictly increasing. !! * 10 = `ty` not non-decreasing. !! * 11 = `nz` out of range. !! * 12 = `kz` out of range. !! * 13 = `z` not strictly increasing. !! * 14 = `tz` not non-decreasing. !! * 15 = `nq` out of range. !! * 16 = `kq` out of range. !! * 17 = `q` not strictly increasing. !! * 18 = `tq` not non-decreasing. !! * 19 = `nr` out of range. !! * 20 = `kr` out of range. !! * 21 = `r` not strictly increasing. !! * 22 = `tr` not non-decreasing. !! * 23 = `ns` out of range. !! * 24 = `ks` out of range. !! * 25 = `s` not strictly increasing. !! * 26 = `ts` not non-decreasing. !! * 700 = `size(x) ` \( \ne \) `size(fcn,1)` !! * 701 = `size(y) ` \( \ne \) `size(fcn,2)` !! * 702 = `size(z) ` \( \ne \) `size(fcn,3)` !! * 703 = `size(q) ` \( \ne \) `size(fcn,4)` !! * 704 = `size(r) ` \( \ne \) `size(fcn,5)` !! * 705 = `size(s) ` \( \ne \) `size(fcn,6)` !! * 706 = `size(x) ` \( \ne \) `nx` !! * 707 = `size(y) ` \( \ne \) `ny` !! * 708 = `size(z) ` \( \ne \) `nz` !! * 709 = `size(q) ` \( \ne \) `nq` !! * 710 = `size(r) ` \( \ne \) `nr` !! * 711 = `size(s) ` \( \ne \) `ns` !! * 712 = `size(tx)` \( \ne \) `nx+kx` !! * 713 = `size(ty)` \( \ne \) `ny+ky` !! * 714 = `size(tz)` \( \ne \) `nz+kz` !! * 715 = `size(tq)` \( \ne \) `nq+kq` !! * 716 = `size(tr)` \( \ne \) `nr+kr` !! * 717 = `size(ts)` \( \ne \) `ns+ks` !! * 800 = `size(x) ` \( \ne \) `size(bcoef,1)` !! * 801 = `size(y) ` \( \ne \) `size(bcoef,2)` !! * 802 = `size(z) ` \( \ne \) `size(bcoef,3)` !! * 803 = `size(q) ` \( \ne \) `size(bcoef,4)` !! * 804 = `size(r) ` \( \ne \) `size(bcoef,5)` !! * 805 = `size(s) ` \( \ne \) `size(bcoef,6)` logical :: status_ok real(wp),dimension(:),allocatable :: temp !! work array of size `nx*ny*nz*nq*nr*ns` real(wp),dimension(:),allocatable :: work !! work array of size `max(2*kx*(nx+1), !! 2*ky*(ny+1),2*kz*(nz+1),2*kq*(nq+1), !! 2*kr*(nr+1),2*ks*(ns+1))` ! check validity of input call check_inputs( iknot,& iflag,& nx=nx,ny=ny,nz=nz,nq=nq,nr=nr,ns=ns,& kx=kx,ky=ky,kz=kz,kq=kq,kr=kr,ks=ks,& x=x,y=y,z=z,q=q,r=r,s=s,& tx=tx,ty=ty,tz=tz,tq=tq,tr=tr,ts=ts,& f6=fcn,& bcoef6=bcoef,& status_ok=status_ok) if (status_ok) then ! choose knots if (iknot == 0_ip) then call dbknot(x,nx,kx,tx) call dbknot(y,ny,ky,ty) call dbknot(z,nz,kz,tz) call dbknot(q,nq,kq,tq) call dbknot(r,nr,kr,tr) call dbknot(s,ns,ks,ts) end if allocate(temp(nx*ny*nz*nq*nr*ns)) allocate(work(max(2_ip*kx*(nx+1_ip),2_ip*ky*(ny+1_ip),& 2_ip*kz*(nz+1_ip),2_ip*kq*(nq+1_ip),& 2_ip*kr*(nr+1_ip),2_ip*ks*(ns+1_ip)))) ! construct b-spline coefficients call dbtpcf(x,nx,fcn, nx,ny*nz*nq*nr*ns,tx,kx,temp, work,iflag) if (iflag==0_ip) call dbtpcf(y,ny,temp, ny,nx*nz*nq*nr*ns,ty,ky,bcoef,work,iflag) if (iflag==0_ip) call dbtpcf(z,nz,bcoef,nz,nx*ny*nq*nr*ns,tz,kz,temp, work,iflag) if (iflag==0_ip) call dbtpcf(q,nq,temp, nq,nx*ny*nz*nr*ns,tq,kq,bcoef,work,iflag) if (iflag==0_ip) call dbtpcf(r,nr,bcoef,nr,nx*ny*nz*nq*ns,tr,kr,temp, work,iflag) if (iflag==0_ip) call dbtpcf(s,ns,temp, ns,nx*ny*nz*nq*nr,ts,ks,bcoef,work,iflag) deallocate(temp) deallocate(work) end if end subroutine db6ink_default !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the tensor product piecewise polynomial ! interpolant constructed by the routine [[db6ink]] or one of its ! derivatives at the point (`xval`,`yval`,`zval`,`qval`,`rval`,`sval`). ! ! To evaluate the ! interpolant itself, set `idx=idy=idz=idq=idr=ids=0`, to evaluate the first ! partial with respect to `x`, set `idx=1,idy=idz=idq=idr=ids=0`, and so on. ! ! See [[db3val]] header for more information. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine db6val_default(xval,yval,zval,qval,rval,sval,& idx,idy,idz,idq,idr,ids,& tx,ty,tz,tq,tr,ts,& nx,ny,nz,nq,nr,ns,& kx,ky,kz,kq,kr,ks,& bcoef,f,iflag,& inbvx,inbvy,inbvz,inbvq,inbvr,inbvs,& iloy,iloz,iloq,ilor,ilos,& w5,w4,w3,w2,w1,w0,extrap) implicit none integer(ip),intent(in) :: idx !! \(x\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idy !! \(y\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idz !! \(z\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idq !! \(q\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: idr !! \(r\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: ids !! \(s\) derivative of piecewise polynomial to evaluate. integer(ip),intent(in) :: nx !! the number of interpolation points in \(x\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: ny !! the number of interpolation points in \(y\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: nz !! the number of interpolation points in \(z\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: nq !! the number of interpolation points in \(q\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: nr !! the number of interpolation points in \(r\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: ns !! the number of interpolation points in \(s\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: kx !! order of polynomial pieces in \(x\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: ky !! order of polynomial pieces in \(y\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: kz !! order of polynomial pieces in \(z\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: kq !! order of polynomial pieces in \(q\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: kr !! order of polynomial pieces in \(r\). !! (same as in last call to [[db6ink]]) integer(ip),intent(in) :: ks !! order of polynomial pieces in \(s\). !! (same as in last call to [[db6ink]]) real(wp),intent(in) :: xval !! \(x\) coordinate of evaluation point. real(wp),intent(in) :: yval !! \(y\) coordinate of evaluation point. real(wp),intent(in) :: zval !! \(z\) coordinate of evaluation point. real(wp),intent(in) :: qval !! \(q\) coordinate of evaluation point. real(wp),intent(in) :: rval !! \(r\) coordinate of evaluation point. real(wp),intent(in) :: sval !! \(s\) coordinate of evaluation point. real(wp),dimension(nx+kx),intent(in) :: tx !! sequence of knots defining the piecewise polynomial !! in the \(x\) direction. !! (same as in last call to [[db6ink]]) real(wp),dimension(ny+ky),intent(in) :: ty !! sequence of knots defining the piecewise polynomial !! in the \(y\) direction. !! (same as in last call to [[db6ink]]) real(wp),dimension(nz+kz),intent(in) :: tz !! sequence of knots defining the piecewise polynomial !! in the \(z\) direction. !! (same as in last call to [[db6ink]]) real(wp),dimension(nq+kq),intent(in) :: tq !! sequence of knots defining the piecewise polynomial !! in the \(q\) direction. !! (same as in last call to [[db6ink]]) real(wp),dimension(nr+kr),intent(in) :: tr !! sequence of knots defining the piecewise polynomial !! in the \(r\) direction. !! (same as in last call to [[db6ink]]) real(wp),dimension(ns+ks),intent(in) :: ts !! sequence of knots defining the piecewise polynomial !! in the \(s\) direction. !! (same as in last call to [[db6ink]]) real(wp),dimension(nx,ny,nz,nq,nr,ns),intent(in) :: bcoef !! the b-spline coefficients computed by [[db6ink]]. real(wp),intent(out) :: f !! interpolated value integer(ip),intent(out) :: iflag !! status flag: !! !! * \( = 0 \) : no errors !! * \( \ne 0 \) : error integer(ip),intent(inout) :: inbvx !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: inbvy !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvz !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvq !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvr !! not used (kept for backward compatibility) integer(ip),intent(inout) :: inbvs !! not used (kept for backward compatibility) integer(ip),intent(inout) :: iloy !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloz !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: iloq !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: ilor !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. integer(ip),intent(inout) :: ilos !! initialization parameter which must be set !! to 1 the first time this routine is called, !! and must not be changed by the user. real(wp),dimension(ky,kz,kq,kr,ks),intent(inout) :: w5 !! work array real(wp),dimension(kz,kq,kr,ks),intent(inout) :: w4 !! work array real(wp),dimension(kq,kr,ks),intent(inout) :: w3 !! work array real(wp),dimension(kr,ks),intent(inout) :: w2 !! work array real(wp),dimension(ks),intent(inout) :: w1 !! work array real(wp),dimension(3_ip*max(kx,ky,kz,kq,kr,ks)),intent(inout) :: w0 !! not used (kept for backward compatibility) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: leftx, lefty, leftz, leftq, leftr, lefts !! interval indices integer(ip) :: ix, iy, iz, iq, ir, is !! coefficient offsets integer(ip) :: j, k, q, r, s !! counters real(wp),dimension(kx) :: bx !! basis function weights in x real(wp),dimension(ky) :: by !! basis function weights in y real(wp),dimension(kz) :: bz !! basis function weights in z real(wp),dimension(kq) :: bq !! basis function weights in q real(wp),dimension(kr) :: br !! basis function weights in r real(wp),dimension(ks) :: bs !! basis function weights in s f = 0.0_wp iflag = check_value(xval,tx,1_ip,extrap); if (iflag/=0_ip) return iflag = check_value(yval,ty,2_ip,extrap); if (iflag/=0_ip) return iflag = check_value(zval,tz,3_ip,extrap); if (iflag/=0_ip) return iflag = check_value(qval,tq,4_ip,extrap); if (iflag/=0_ip) return iflag = check_value(rval,tr,5_ip,extrap); if (iflag/=0_ip) return iflag = check_value(sval,ts,6_ip,extrap); if (iflag/=0_ip) return ! interval and basis function weights in each direction call dbvalu_weights(tx,nx,kx,idx,xval,inbvx,leftx,bx,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ty,ny,ky,idy,yval,iloy,lefty,by,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tz,nz,kz,idz,zval,iloz,leftz,bz,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tq,nq,kq,idq,qval,iloq,leftq,bq,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(tr,nr,kr,idr,rval,ilor,leftr,br,iflag,extrap) if (iflag/=0_ip) return call dbvalu_weights(ts,ns,ks,ids,sval,ilos,lefts,bs,iflag,extrap) if (iflag/=0_ip) return ix = leftx - kx iy = lefty - ky iz = leftz - kz iq = leftq - kq ir = leftr - kr is = lefts - ks ! contract the coefficients one direction at a time do s=1_ip,ks do r=1_ip,kr do q=1_ip,kq do k=1_ip,kz do j=1_ip,ky w5(j,k,q,r,s) = dot_product(bx,bcoef(ix+1_ip:leftx,iy+j,iz+k,iq+q,ir+r,is+s)) end do w4(k,q,r,s) = dot_product(by,w5(:,k,q,r,s)) end do w3(q,r,s) = dot_product(bz,w4(:,q,r,s)) end do w2(r,s) = dot_product(bq,w3(:,r,s)) end do w1(s) = dot_product(br,w2(:,s)) end do f = dot_product(bs,w1) end subroutine db6val_default !***************************************************************************************** !***************************************************************************************** !> ! Checks if the value is withing the range of the knot vectors. ! This is called by the various `db*val` routines. pure function check_value(x,t,i,extrap) result(iflag) implicit none integer(ip) :: iflag !! returns 0 if value is OK, otherwise returns `600+i` real(wp),intent(in) :: x !! the value to check integer(ip),intent(in) :: i !! 1=x, 2=y, 3=z, 4=q, 5=r, 6=s real(wp),dimension(:),intent(in) :: t !! the knot vector logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) logical :: allow_extrapolation !! if extrapolation is allowed if (present(extrap)) then allow_extrapolation = extrap else allow_extrapolation = .false. end if if (allow_extrapolation) then ! in this case all values are OK iflag = 0_ip else if (x<t(1_ip) .or. x>t(size(t,kind=ip))) then iflag = 600_ip + i ! value out of bounds (601, 602, etc.) else iflag = 0_ip end if end if end function check_value !***************************************************************************************** !***************************************************************************************** !> ! Check the validity of the inputs to the `db*ink` routines. ! Prints warning message if there is an error, ! and also sets iflag and status_ok. ! ! Supports up to 6D: `x`,`y`,`z`,`q`,`r`,`s` ! !### Notes ! ! The code is new, but the logic is based on the original ! logic in the CMLIB routines `db2ink` and `db3ink`. ! !### History ! * Jacob Williams, 2/24/2015 : Created this routine. pure subroutine check_inputs(iknot,& iflag,& nx,ny,nz,nq,nr,ns,& kx,ky,kz,kq,kr,ks,& x,y,z,q,r,s,& tx,ty,tz,tq,tr,ts,& f1,f2,f3,f4,f5,f6,& bcoef1,bcoef2,bcoef3,bcoef4,bcoef5,bcoef6,& alt,& status_ok) implicit none integer(ip),intent(in) :: iknot !! = 0 if the `INK` routine is computing the knots. integer(ip),intent(out) :: iflag integer(ip),intent(in),optional :: nx,ny,nz,nq,nr,ns integer(ip),intent(in),optional :: kx,ky,kz,kq,kr,ks real(wp),dimension(:),intent(in),optional :: x,y,z,q,r,s real(wp),dimension(:),intent(in),optional :: tx,ty,tz,tq,tr,ts real(wp),dimension(:),intent(in),optional :: f1,bcoef1 real(wp),dimension(:,:),intent(in),optional :: f2,bcoef2 real(wp),dimension(:,:,:),intent(in),optional :: f3,bcoef3 real(wp),dimension(:,:,:,:),intent(in),optional :: f4,bcoef4 real(wp),dimension(:,:,:,:,:),intent(in),optional :: f5,bcoef5 real(wp),dimension(:,:,:,:,:,:),intent(in),optional :: f6,bcoef6 logical,intent(in),optional :: alt !! using the alt routine where 1st or !! 2nd deriv is fixed at endpoints !! [default is False] logical,intent(out) :: status_ok logical :: error integer :: iex !! extra points for the alt case (in `t` and `bcoef`) !! [currently, only allowed for the 1D case] status_ok = .false. iex = 0_ip ! default if (present(alt)) then if (alt) iex = 2_ip ! for "alt" mode end if if ((iknot < 0_ip) .or. (iknot > 1_ip)) then iflag = 2_ip ! iknot is out of range else call check('x',nx,kx,x,tx,[3_ip, 4_ip, 5_ip, 6_ip,706_ip,712_ip],iflag,error,iex); if (error) return call check('y',ny,ky,y,ty,[7_ip, 8_ip, 9_ip,10_ip,707_ip,713_ip],iflag,error,iex); if (error) return call check('z',nz,kz,z,tz,[11_ip,12_ip,13_ip,14_ip,708_ip,714_ip],iflag,error,iex); if (error) return call check('q',nq,kq,q,tq,[15_ip,16_ip,17_ip,18_ip,709_ip,715_ip],iflag,error,iex); if (error) return call check('r',nr,kr,r,tr,[19_ip,20_ip,21_ip,22_ip,710_ip,716_ip],iflag,error,iex); if (error) return call check('s',ns,ks,s,ts,[23_ip,24_ip,25_ip,26_ip,711_ip,717_ip],iflag,error,iex); if (error) return if (present(x) .and. present(f1) .and. present(bcoef1)) then if (size(x,kind=ip)/=size(f1,1_ip,kind=ip)) then; iflag = 700_ip; return; end if if (size(x,kind=ip)+iex/=size(bcoef1,1_ip,kind=ip)) then; iflag = 800_ip; return; end if end if if (present(x) .and. present(y) .and. present(f2) .and. present(bcoef2)) then if (size(x,kind=ip)/=size(f2,1_ip,kind=ip)) then; iflag = 700_ip; return; end if if (size(y,kind=ip)/=size(f2,2_ip,kind=ip)) then; iflag = 701_ip; return; end if if (size(x,kind=ip)+iex/=size(bcoef2,1_ip,kind=ip)) then; iflag = 800_ip; return; end if if (size(y,kind=ip)+iex/=size(bcoef2,2_ip,kind=ip)) then; iflag = 801_ip; return; end if end if if (present(x) .and. present(y) .and. present(z) .and. present(f3) .and. & present(bcoef3)) then if (size(x,kind=ip)/=size(f3,1_ip,kind=ip)) then; iflag = 700_ip; return; end if if (size(y,kind=ip)/=size(f3,2_ip,kind=ip)) then; iflag = 701_ip; return; end if if (size(z,kind=ip)/=size(f3,3_ip,kind=ip)) then; iflag = 702_ip; return; end if if (size(x,kind=ip)+iex/=size(bcoef3,1_ip,kind=ip)) then; iflag = 800_ip; return; end if if (size(y,kind=ip)+iex/=size(bcoef3,2_ip,kind=ip)) then; iflag = 801_ip; return; end if if (size(z,kind=ip)+iex/=size(bcoef3,3_ip,kind=ip)) then; iflag = 802_ip; return; end if end if if (present(x) .and. present(y) .and. present(z) .and. present(q) .and. & present(f4) .and. present(bcoef4)) then if (size(x,kind=ip)/=size(f4,1_ip,kind=ip)) then; iflag = 700_ip; return; end if if (size(y,kind=ip)/=size(f4,2_ip,kind=ip)) then; iflag = 701_ip; return; end if if (size(z,kind=ip)/=size(f4,3_ip,kind=ip)) then; iflag = 702_ip; return; end if if (size(q,kind=ip)/=size(f4,4_ip,kind=ip)) then; iflag = 703_ip; return; end if if (size(x,kind=ip)+iex/=size(bcoef4,1_ip,kind=ip)) then; iflag = 800_ip; return; end if if (size(y,kind=ip)+iex/=size(bcoef4,2_ip,kind=ip)) then; iflag = 801_ip; return; end if if (size(z,kind=ip)+iex/=size(bcoef4,3_ip,kind=ip)) then; iflag = 802_ip; return; end if if (size(q,kind=ip)+iex/=size(bcoef4,4_ip,kind=ip)) then; iflag = 803_ip; return; end if end if if (present(x) .and. present(y) .and. present(z) .and. present(q) .and. & present(r) .and. present(f5) .and. present(bcoef5)) then if (size(x,kind=ip)/=size(f5,1_ip,kind=ip)) then; iflag = 700_ip; return; end if if (size(y,kind=ip)/=size(f5,2_ip,kind=ip)) then; iflag = 701_ip; return; end if if (size(z,kind=ip)/=size(f5,3_ip,kind=ip)) then; iflag = 702_ip; return; end if if (size(q,kind=ip)/=size(f5,4_ip,kind=ip)) then; iflag = 703_ip; return; end if if (size(r,kind=ip)/=size(f5,5_ip,kind=ip)) then; iflag = 704_ip; return; end if if (size(x,kind=ip)+iex/=size(bcoef5,1_ip,kind=ip)) then; iflag = 800_ip; return; end if if (size(y,kind=ip)+iex/=size(bcoef5,2_ip,kind=ip)) then; iflag = 801_ip; return; end if if (size(z,kind=ip)+iex/=size(bcoef5,3_ip,kind=ip)) then; iflag = 802_ip; return; end if if (size(q,kind=ip)+iex/=size(bcoef5,4_ip,kind=ip)) then; iflag = 803_ip; return; end if if (size(r,kind=ip)+iex/=size(bcoef5,5_ip,kind=ip)) then; iflag = 804_ip; return; end if end if if (present(x) .and. present(y) .and. present(z) .and. present(q) .and. & present(r) .and. present(s) .and. present(f6) .and. present(bcoef6)) then if (size(x,kind=ip)/=size(f6,1_ip,kind=ip)) then; iflag = 700_ip; return; end if if (size(y,kind=ip)/=size(f6,2_ip,kind=ip)) then; iflag = 701_ip; return; end if if (size(z,kind=ip)/=size(f6,3_ip,kind=ip)) then; iflag = 702_ip; return; end if if (size(q,kind=ip)/=size(f6,4_ip,kind=ip)) then; iflag = 703_ip; return; end if if (size(r,kind=ip)/=size(f6,5_ip,kind=ip)) then; iflag = 704_ip; return; end if if (size(s,kind=ip)/=size(f6,6_ip,kind=ip)) then; iflag = 705_ip; return; end if if (size(x,kind=ip)+iex/=size(bcoef6,1_ip,kind=ip)) then; iflag = 800_ip; return; end if if (size(y,kind=ip)+iex/=size(bcoef6,2_ip,kind=ip)) then; iflag = 801_ip; return; end if if (size(z,kind=ip)+iex/=size(bcoef6,3_ip,kind=ip)) then; iflag = 802_ip; return; end if if (size(q,kind=ip)+iex/=size(bcoef6,4_ip,kind=ip)) then; iflag = 803_ip; return; end if if (size(r,kind=ip)+iex/=size(bcoef6,5_ip,kind=ip)) then; iflag = 804_ip; return; end if if (size(s,kind=ip)+iex/=size(bcoef6,6_ip,kind=ip)) then; iflag = 805_ip; return; end if end if status_ok = .true. iflag = 0_ip end if contains pure subroutine check(s,n,k,x,t,ierrs,iflag,error,ik) !! check `t`,`x`,`n`,`k` for validity implicit none character(len=1),intent(in) :: s !! coordinate string: 'x','y','z','q','r','s' integer(ip),intent(in),optional :: n !! size of `x` integer(ip),intent(in),optional :: k !! order real(wp),dimension(:),intent(in),optional :: x !! abcissae vector real(wp),dimension(:),intent(in),optional :: t !! knot vector `size(n+k)` integer(ip),dimension(:),intent(in) :: ierrs !! int error codes for `n`,`k`,`x`,`t`, !! `size(x)`,`size(t)` checks integer(ip),intent(out) :: iflag !! status return code logical,intent(out) :: error !! true if there was an error integer,intent(in) :: ik !! add this value to k integer(ip),dimension(2) :: itmp !! temp integer array if (present(n) .and. present(k) .and. present(x) .and. present(t)) then itmp = [ierrs(1_ip),ierrs(5)] call check_n('n'//s,n,x,itmp,iflag,error); if (error) return if (ik > 0) then ! alt mode: there are `n+ik` coefficients, so `k <= n+ik` is allowed call check_k('k'//s,k,n+ik,ierrs(2),iflag,error) else call check_k('k'//s,k,n-1_ip,ierrs(2),iflag,error) end if if (error) return call check_x(s,n,x,ierrs(3),iflag,error); if (error) return if (iknot /= 0_ip) then itmp = [ierrs(4),ierrs(6)] call check_t('t'//s,n,k+ik,t,itmp,iflag,error); if (error) return end if end if end subroutine check pure subroutine check_n(s,n,x,ierr,iflag,error) implicit none character(len=*),intent(in) :: s integer(ip),intent(in) :: n real(wp),dimension(:),intent(in) :: x !! abcissae vector integer(ip),dimension(2),intent(in) :: ierr !! [n<nmin check, size(x)==n check] integer(ip),intent(out) :: iflag !! status return code logical,intent(out) :: error integer(ip) :: nmin !! minimum number of points ! [[dbint4]] (alt mode) only requires 2 points (and `k <= n+2`, checked below) nmin = merge(2_ip, 3_ip, iex>0_ip) if (n < nmin) then iflag = ierr(1_ip) error = .true. else if (size(x)/=n) then iflag = ierr(2) error = .true. else error = .false. end if end if end subroutine check_n pure subroutine check_k(s,k,kmax,ierr,iflag,error) implicit none character(len=*),intent(in) :: s integer(ip),intent(in) :: k integer(ip),intent(in) :: kmax !! maximum allowed value of `k` integer(ip),intent(in) :: ierr integer(ip),intent(out) :: iflag !! status return code logical,intent(out) :: error if ((k < 2_ip) .or. (k > kmax)) then iflag = ierr error = .true. else error = .false. end if end subroutine check_k pure subroutine check_x(s,n,x,ierr,iflag,error) implicit none character(len=*),intent(in) :: s integer(ip),intent(in) :: n real(wp),dimension(:),intent(in) :: x integer(ip),intent(in) :: ierr integer(ip),intent(out) :: iflag !! status return code logical,intent(out) :: error integer(ip) :: i error = .true. do i=2_ip,n if (x(i) <= x(i-1_ip)) then iflag = ierr return end if end do error = .false. end subroutine check_x pure subroutine check_t(s,n,k,t,ierr,iflag,error) implicit none character(len=*),intent(in) :: s integer(ip),intent(in) :: n integer(ip),intent(in) :: k real(wp),dimension(:),intent(in) :: t integer(ip),dimension(2),intent(in) :: ierr !! [non-decreasing check, size check] integer(ip),intent(out) :: iflag !! status return code logical,intent(out) :: error integer(ip) :: i error = .true. if (size(t)/=(n+k)) then iflag = ierr(2) return end if if (iex==0_ip) then ! don't do this for "alt" mode since they haven't been computed yet do i=2_ip,n + k if (t(i) < t(i-1_ip)) then iflag = ierr(1_ip) return end if end do end if error = .false. end subroutine check_t end subroutine check_inputs !***************************************************************************************** !***************************************************************************************** !> ! dbknot chooses a knot sequence for interpolation of order k at the ! data points x(i), i=1,..,n. the n+k knots are placed in the array ! t. k knots are placed at each endpoint and not-a-knot end ! conditions are used. the remaining knots are placed at data points ! if n is even and between data points if n is odd. the rightmost ! knot is shifted slightly to the right to insure proper interpolation ! at x(n) (see page 350 of the reference). ! !### History ! * Jacob Williams, 2/24/2015 : Refactored this routine. pure subroutine dbknot(x,n,k,t) implicit none integer(ip),intent(in) :: n !! dimension of `x` integer(ip),intent(in) :: k real(wp),dimension(:),intent(in) :: x real(wp),dimension(:),intent(out) :: t integer(ip) :: i, j, ipj, npj, ip1, jstrt real(wp) :: rnot !put k knots at each endpoint !(shift right endpoints slightly -- see pg 350 of reference) rnot = x(n) + 0.1_wp*( x(n)-x(n-1_ip) ) do j=1_ip,k t(j) = x(1_ip) npj = n + j t(npj) = rnot end do !distribute remaining knots if (mod(k,2_ip) == 1_ip) then !case of odd k -- knots between data points i = (k-1_ip)/2_ip - k ip1 = i + 1_ip jstrt = k + 1_ip do j=jstrt,n ipj = i + j t(j) = 0.5_wp*( x(ipj) + x(ipj+1_ip) ) end do else !case of even k -- knots at data points i = (k/2_ip) - k jstrt = k+1_ip do j=jstrt,n ipj = i + j t(j) = x(ipj) end do end if end subroutine dbknot !***************************************************************************************** !***************************************************************************************** !> ! dbtpcf computes b-spline interpolation coefficients for nf sets ! of data stored in the columns of the array fcn. the b-spline ! coefficients are stored in the rows of bcoef however. ! each interpolation is based on the n abcissa stored in the ! array x, and the n+k knots stored in the array t. the order ! of each interpolation is k. ! !### History ! * Jacob Williams, 2/24/2015 : Refactored this routine. pure subroutine dbtpcf(x,n,fcn,ldf,nf,t,k,bcoef,work,iflag) integer(ip),intent(in) :: n !! dimension of `x` integer(ip),intent(in) :: nf integer(ip),intent(in) :: ldf integer(ip),intent(in) :: k real(wp),dimension(:),intent(in) :: x real(wp),dimension(ldf,nf),intent(in) :: fcn real(wp),dimension(:),intent(in) :: t real(wp),dimension(nf,n),intent(out) :: bcoef real(wp),dimension(*),intent(out) :: work !! work array of size >= `2*k*(n+1)` integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 301: n should be >0 integer(ip) :: i, j, m1, m2, iq, iw ! check for null input if (nf > 0_ip) then ! partition work array m1 = k - 1_ip m2 = m1 + k iq = 1_ip + n iw = iq + m2*n+1_ip ! compute b-spline coefficients ! first data set call dbintk(x,fcn,t,n,k,work,work(iq),work(iw),iflag) if (iflag == 0_ip) then do i=1_ip,n bcoef(1_ip,i) = work(i) end do ! all remaining data sets by back-substitution if (nf == 1_ip) return do j=2_ip,nf do i=1_ip,n work(i) = fcn(i,j) end do call dbnslv(work(iq),m2,n,m1,m1,work) do i=1_ip,n bcoef(j,i) = work(i) end do end do end if else !write(error_unit,'(A)') 'dbtpcf - n should be >0' iflag = 301_ip end if end subroutine dbtpcf !***************************************************************************************** !***************************************************************************************** !> ! dbintk produces the b-spline coefficients, bcoef, of the ! b-spline of order k with knots t(i), i=1,...,n+k, which ! takes on the value y(i) at x(i), i=1,...,n. the spline or ! any of its derivatives can be evaluated by calls to [[dbvalu]]. ! ! the i-th equation of the linear system a*bcoef = b for the ! coefficients of the interpolant enforces interpolation at ! x(i), i=1,...,n. hence, b(i) = y(i), for all i, and a is ! a band matrix with 2k-1 bands if a is invertible. the matrix ! a is generated row by row and stored, diagonal by diagonal, ! in the rows of q, with the main diagonal going into row k. ! the banded system is then solved by a call to dbnfac (which ! constructs the triangular factorization for a and stores it ! again in q), followed by a call to dbnslv (which then ! obtains the solution bcoef by substitution). dbnfac does no ! pivoting, since the total positivity of the matrix a makes ! this unnecessary. the linear system to be solved is ! (theoretically) invertible if and only if ! t(i) < x(i) < t(i+k), for all i. ! equality is permitted on the left for i=1 and on the right ! for i=n when k knots are used at x(1) or x(n). otherwise, ! violation of this condition is certain to lead to an error. ! !### Error conditions ! ! * improper input ! * singular system of equations ! !### History ! * splint written by carl de boor [5] ! * dbintk author: amos, d. e., (snla) : date written 800901 ! * revision date 820801 ! * 000330 modified array declarations. (jec) ! * Jacob Williams, 5/10/2015 : converted to free-form Fortran. pure subroutine dbintk(x,y,t,n,k,bcoef,q,work,iflag) implicit none integer(ip),intent(in) :: n !! number of data points, n >= k real(wp),dimension(n),intent(in) :: x !! vector of length n containing data point abscissa !! in strictly increasing order. real(wp),dimension(n),intent(in) :: y !! corresponding vector of length n containing data !! point ordinates. real(wp),dimension(*),intent(in) :: t !! knot vector of length n+k !! since t(1),..,t(k) <= x(1) and t(n+1),..,t(n+k) !! >= x(n), this leaves only n-k knots (not !! necessarily x(i) values) interior to (x(1),x(n)) integer(ip),intent(in) :: k !! order of the spline, k >= 1 real(wp),dimension(n),intent(out) :: bcoef !! a vector of length n containing the b-spline coefficients real(wp),dimension(*),intent(out) :: q !! a work vector of length (2*k-1)*n, containing !! the triangular factorization of the coefficient !! matrix of the linear system being solved. the !! coefficients for the interpolant of an !! additional data set (x(i),yy(i)), i=1,...,n !! with the same abscissa can be obtained by loading !! yy into bcoef and then executing !! call dbnslv(q,2k-1,n,k-1,k-1,bcoef) real(wp),dimension(*),intent(out) :: work !! work vector of length 2*k integer(ip),intent(out) :: iflag !! * 0: no errors. !! * 100: k does not satisfy k>=1. !! * 101: n does not satisfy n>=k. !! * 102: x(i) does not satisfy x(i)<x(i+1) for some i. !! * 103: some abscissa was not in the support of the !! corresponding basis function and the system is singular. !! * 104: the system of solver detects a singular system. !! although the theoretical conditions for a solution were satisfied. integer(ip) :: iwork, i, ilp1mx, j, jj, km1, kpkm2, left,lenq, np1 real(wp) :: xi logical :: found if (k<1_ip) then !write(error_unit,'(A)') 'dbintk - k does not satisfy k>=1' iflag = 100_ip return end if if (n<k) then !write(error_unit,'(A)') 'dbintk - n does not satisfy n>=k' iflag = 101_ip return end if jj = n - 1_ip if (jj/=0_ip) then do i=1_ip,jj if (x(i)>=x(i+1_ip)) then !write(error_unit,'(A)') 'dbintk - x(i) does not satisfy x(i)<x(i+1) for some i' iflag = 102_ip return end if end do end if np1 = n + 1_ip km1 = k - 1_ip kpkm2 = 2_ip*km1 left = k ! zero out all entries of q lenq = n*(k+km1) do i=1_ip,lenq q(i) = 0.0_wp end do ! loop over i to construct the n interpolation equations do i=1_ip,n xi = x(i) ilp1mx = min(i+k,np1) ! find left in the closed interval (i,i+k-1_ip) such that ! t(left) <= x(i) < t(left+1_ip) ! matrix is singular if this is not possible left = max(left,i) if (xi<t(left)) then !write(error_unit,'(A)') 'dbintk - some abscissa was not in the support of the'//& ! ' corresponding basis function and the system is singular' iflag = 103_ip return end if found = .false. do found = (xi<t(left+1_ip)) if (found) exit left = left + 1_ip if (left>=ilp1mx) exit end do if (.not. found) then left = left - 1_ip if (xi>t(left+1_ip)) then !write(error_unit,'(A)') 'dbintk - some abscissa was not in the support of the'//& ! ' corresponding basis function and the system is singular' iflag = 103_ip return end if end if ! the i-th equation enforces interpolation at xi, hence ! a(i,j) = b(j,k,t)(xi), all j. only the k entries with j = ! left-k+1,...,left actually might be nonzero. these k numbers ! are returned, in bcoef (used for temp.storage here), by the ! following call dbspvn(t, k, k, 1_ip, xi, left, bcoef, work, iwork, iflag) if (iflag/=0_ip) return ! we therefore want bcoef(j) = b(left-k+j)(xi) to go into ! a(i,left-k+j), i.e., into q(i-(left+j)+2*k,(left+j)-k) since ! a(i+j,j) is to go into q(i+k,j), all i,j, if we consider q ! as a two-dim. array , with 2*k-1 rows (see comments in ! dbnfac). in the present program, we treat q as an equivalent ! one-dimensional array (because of fortran restrictions on ! dimension statements) . we therefore want bcoef(j) to go into ! entry ! i -(left+j) + 2*k + ((left+j) - k-1)*(2*k-1) ! = i-left+1 + (left -k)*(2*k-1) + (2*k-2)*j ! of q. jj = i - left + 1_ip + (left-k)*(k+km1) do j=1_ip,k jj = jj + kpkm2 q(jj) = bcoef(j) end do end do ! obtain factorization of a, stored again in q. call dbnfac(q, k+km1, n, km1, km1, iflag) if (iflag==1) then !success ! solve a*bcoef = y by backsubstitution do i=1_ip,n bcoef(i) = y(i) end do call dbnslv(q, k+km1, n, km1, km1, bcoef) iflag = 0_ip else !failure !write(error_unit,'(A)') 'dbintk - the system of solver detects a singular system'//& ! ' although the theoretical conditions for a solution were satisfied' iflag = 104_ip end if end subroutine dbintk !***************************************************************************************** !***************************************************************************************** !> ! Returns in w the LU-factorization (without pivoting) of the banded ! matrix a of order nrow with (nbandl + 1 + nbandu) bands or diagonals ! in the work array w . ! ! gauss elimination without pivoting is used. the routine is ! intended for use with matrices a which do not require row inter- ! changes during factorization, especially for the totally ! positive matrices which occur in spline calculations. ! the routine should not be used for an arbitrary banded matrix. ! !### Work array ! ! **Input** ! ! w array of size (nroww,nrow) contains the interesting ! part of a banded matrix a , with the diagonals or bands of a ! stored in the rows of w , while columns of a correspond to ! columns of w . this is the storage mode used in linpack and ! results in efficient innermost loops. ! explicitly, a has nbandl bands below the diagonal ! + 1 (main) diagonal ! + nbandu bands above the diagonal ! and thus, with middle = nbandu + 1, ! a(i+j,j) is in w(i+middle,j) for i=-nbandu,...,nbandl ! j=1,...,nrow . ! for example, the interesting entries of a (1,2)-banded matrix ! of order 9 would appear in the first 1+1+2 = 4 rows of w ! as follows. ! 13 24 35 46 57 68 79 ! 12 23 34 45 56 67 78 89 ! 11 22 33 44 55 66 77 88 99 ! 21 32 43 54 65 76 87 98 ! ! all other entries of w not identified in this way with an en- ! try of a are never referenced . ! ! **Output** ! ! * if iflag = 1, then ! w contains the lu-factorization of a into a unit lower triangu- ! lar matrix l and an upper triangular matrix u (both banded) ! and stored in customary fashion over the corresponding entries ! of a . this makes it possible to solve any particular linear ! system a*x = b for x by a ! call dbnslv ( w, nroww, nrow, nbandl, nbandu, b ) ! with the solution x contained in b on return . ! * if iflag = 2, then ! one of nrow-1, nbandl,nbandu failed to be nonnegative, or else ! one of the potential pivots was found to be zero indicating ! that a does not have an lu-factorization. this implies that ! a is singular in case it is totally positive . ! !### History ! * banfac written by carl de boor [5] ! * dbnfac from CMLIB [1] ! * Jacob Williams, 5/10/2015 : converted to free-form Fortran. pure subroutine dbnfac(w,nroww,nrow,nbandl,nbandu,iflag) integer(ip),intent(in) :: nroww !! row dimension of the work array w. must be >= nbandl + 1 + nbandu. integer(ip),intent(in) :: nrow !! matrix order integer(ip),intent(in) :: nbandl !! number of bands of a below the main diagonal integer(ip),intent(in) :: nbandu !! number of bands of a above the main diagonal integer(ip),intent(out) :: iflag !! indicating success(=1) or failure (=2) real(wp),dimension(nroww,nrow),intent(inout) :: w !! work array. See header for details. integer(ip) :: i, ipk, j, jmax, k, kmax, middle, midmk, nrowm1 real(wp) :: factor, pivot iflag = 1_ip middle = nbandu + 1_ip ! w(middle,.) contains the main diagonal of a. nrowm1 = nrow - 1_ip if (nrowm1 < 0_ip) then iflag = 2_ip return else if (nrowm1 == 0_ip) then if (w(middle,nrow)==0.0_wp) iflag = 2_ip return end if if (nbandl<=0_ip) then ! a is upper triangular. check that diagonal is nonzero . do i=1_ip,nrowm1 if (w(middle,i)==0.0_wp) then iflag = 2_ip return end if end do if (w(middle,nrow)==0.0_wp) iflag = 2_ip return end if if (nbandu<=0_ip) then ! a is lower triangular. check that diagonal is nonzero and ! divide each column by its diagonal. do i=1_ip,nrowm1 pivot = w(middle,i) if (pivot==0.0_wp) then iflag = 2_ip return end if jmax = min(nbandl,nrow-i) do j=1_ip,jmax w(middle+j,i) = w(middle+j,i)/pivot end do end do return end if ! a is not just a triangular matrix. construct lu factorization do i=1_ip,nrowm1 ! w(middle,i) is pivot for i-th step . pivot = w(middle,i) if (pivot==0.0_wp) then iflag = 2_ip return end if ! jmax is the number of (nonzero) entries in column i ! below the diagonal. jmax = min(nbandl,nrow-i) ! divide each entry in column i below diagonal by pivot. do j=1_ip,jmax w(middle+j,i) = w(middle+j,i)/pivot end do ! kmax is the number of (nonzero) entries in row i to ! the right of the diagonal. kmax = min(nbandu,nrow-i) ! subtract a(i,i+k)*(i-th column) from (i+k)-th column ! (below row i). do k=1_ip,kmax ipk = i + k midmk = middle - k factor = w(midmk,ipk) do j=1_ip,jmax w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i)*factor end do end do end do ! check the last diagonal entry. if (w(middle,nrow)==0.0_wp) iflag = 2_ip end subroutine dbnfac !***************************************************************************************** !***************************************************************************************** !> ! Companion routine to [[dbnfac]]. it returns the solution x of the ! linear system a*x = b in place of b, given the lu-factorization ! for a in the work array w from dbnfac. ! ! (with \( a = l*u \), as stored in w), the unit lower triangular system ! \( l(u*x) = b \) is solved for \( y = u*x \), and y stored in b. then the ! upper triangular system \(u*x = y \) is solved for x. the calculations ! are so arranged that the innermost loops stay within columns. ! !### History ! * banslv written by carl de boor [5] ! * dbnslv from SLATEC library [1] ! * Jacob Williams, 5/10/2015 : converted to free-form Fortran. pure subroutine dbnslv(w,nroww,nrow,nbandl,nbandu,b) integer(ip),intent(in) :: nroww !! describes the lu-factorization of a banded matrix a of order `nrow` !! as constructed in [[dbnfac]]. integer(ip),intent(in) :: nrow !! describes the lu-factorization of a banded matrix a of order `nrow` !! as constructed in [[dbnfac]]. integer(ip),intent(in) :: nbandl !! describes the lu-factorization of a banded matrix a of order `nrow` !! as constructed in [[dbnfac]]. integer(ip),intent(in) :: nbandu !! describes the lu-factorization of a banded matrix a of order `nrow` !! as constructed in [[dbnfac]]. real(wp),dimension(nroww,nrow),intent(in) :: w !! describes the lu-factorization of a banded matrix a of !! order `nrow` as constructed in [[dbnfac]]. real(wp),dimension(nrow),intent(inout) :: b !! * **in**: right side of the system to be solved !! * **out**: the solution x, of order nrow integer(ip) :: i, j, jmax, middle, nrowm1 middle = nbandu + 1_ip if (nrow/=1_ip) then nrowm1 = nrow - 1_ip if (nbandl/=0_ip) then ! forward pass ! for i=1,2,...,nrow-1, subtract right side(i)*(i-th column of l) ! from right side (below i-th row). do i=1_ip,nrowm1 jmax = min(nbandl,nrow-i) do j=1_ip,jmax b(i+j) = b(i+j) - b(i)*w(middle+j,i) end do end do end if ! backward pass ! for i=nrow,nrow-1,...,1, divide right side(i) by i-th diagonal ! entry of u, then subtract right side(i)*(i-th column ! of u) from right side (above i-th row). if (nbandu<=0_ip) then ! a is lower triangular. do i=1_ip,nrow b(i) = b(i)/w(1_ip,i) end do return end if i = nrow do b(i) = b(i)/w(middle,i) jmax = min(nbandu,i-1_ip) do j=1_ip,jmax b(i-j) = b(i-j) - b(i)*w(middle-j,i) end do i = i - 1_ip if (i<=1_ip) exit end do end if b(1_ip) = b(1_ip)/w(middle,1_ip) end subroutine dbnslv !***************************************************************************************** !***************************************************************************************** !> ! Calculates the value of all (possibly) nonzero basis ! functions at x of order max(jhigh,(j+1)*(index-1)), where t(k) ! <= x <= t(n+1) and j=iwork is set inside the routine on ! the first call when index=1. ileft is such that t(ileft) <= ! x < t(ileft+1). a call to dintrv(t,n+1,x,ilo,ileft,mflag) ! produces the proper ileft. dbspvn calculates using the basic ! algorithm needed in dbspvd. if only basis functions are ! desired, setting jhigh=k and index=1 can be faster than ! calling dbspvd, but extra coding is required for derivatives ! (index=2) and dbspvd is set up for this purpose. ! ! left limiting values are set up as described in dbspvd. ! !### Error Conditions ! ! * improper input ! !### History ! * bsplvn written by carl de boor [5] ! * dbspvn author: amos, d. e., (snla) : date written 800901 ! * revision date 820801 ! * 000330 modified array declarations. (jec) ! * Jacob Williams, 2/24/2015 : extensive refactoring of CMLIB routine. pure subroutine dbspvn(t,jhigh,k,index,x,ileft,vnikx,work,iwork,iflag) implicit none real(wp),dimension(*),intent(in) :: t !! knot vector of length `n+k`, where !! `n` = number of b-spline basis functions !! `n` = sum of knot multiplicities-`k` !! dimension `t(ileft+jhigh)` integer(ip),intent(in) :: jhigh !! order of b-spline, `1 <= jhigh <= k` integer(ip),intent(in) :: k !! highest possible order integer(ip),intent(in) :: index !! index = 1 gives basis functions of order `jhigh` !! = 2 denotes previous entry with `work`, `iwork` !! values saved for subsequent calls to !! dbspvn. real(wp),intent(in) :: x !! argument of basis functions, `t(k) <= x <= t(n+1)` integer(ip),intent(in) :: ileft !! largest integer such that `t(ileft) <= x < t(ileft+1)` real(wp),dimension(k),intent(out) :: vnikx !! vector of length `k` for spline values. real(wp),dimension(*),intent(inout) :: work !! a work vector of length `2*k` integer(ip),intent(inout) :: iwork !! a work parameter. both `work` and `iwork` contain !! information necessary to continue for `index = 2`. !! when `index = 1` exclusively, these are scratch !! variables and can be used for other purposes. integer(ip),intent(out) :: iflag !! * 0: no errors !! * 201: `k` does not satisfy `k>=1` !! * 202: `jhigh` does not satisfy `1<=jhigh<=k` !! * 203: `index` is not 1 or 2 !! * 204: `x` does not satisfy `t(ileft)<=x<=t(ileft+1)` integer(ip) :: imjp1, ipj, jp1, jp1ml, l real(wp) :: vm, vmprev ! content of j, deltam, deltap is expected unchanged between calls. ! work(i) = deltap(i), ! work(k+i) = deltam(i), i = 1,k if (k<1_ip) then !write(error_unit,'(A)') 'dbspvn - k does not satisfy k>=1' iflag = 201_ip return end if if (jhigh>k .or. jhigh<1_ip) then !write(error_unit,'(A)') 'dbspvn - jhigh does not satisfy 1<=jhigh<=k' iflag = 202_ip return end if if (index<1_ip .or. index>2_ip) then !write(error_unit,'(A)') 'dbspvn - index is not 1 or 2' iflag = 203_ip return end if if (x<t(ileft) .or. x>t(ileft+1_ip)) then !write(error_unit,'(A)') 'dbspvn - x does not satisfy t(ileft)<=x<=t(ileft+1)' iflag = 204_ip return end if iflag = 0_ip if (index==1_ip) then iwork = 1_ip vnikx(1_ip) = 1.0_wp if (iwork>=jhigh) return end if do ipj = ileft + iwork work(iwork) = t(ipj) - x imjp1 = ileft - iwork + 1_ip work(k+iwork) = x - t(imjp1) vmprev = 0.0_wp jp1 = iwork + 1_ip do l=1_ip,iwork jp1ml = jp1 - l vm = vnikx(l)/(work(l)+work(k+jp1ml)) vnikx(l) = vm*work(l) + vmprev vmprev = vm*work(k+jp1ml) end do vnikx(jp1) = vmprev iwork = jp1 if (iwork>=jhigh) exit end do end subroutine dbspvn !***************************************************************************************** !***************************************************************************************** !> ! Evaluates the b-representation (`t`,`a`,`n`,`k`) of a b-spline ! at `x` for the function value on `ideriv=0` or any of its ! derivatives on `ideriv=1,2,...,k-1`. right limiting values ! (right derivatives) are returned except at the right end ! point `x=t(n+1)` where left limiting values are computed. the ! spline is defined on `t(k)` \( \le \) `x` \( \le \) `t(n+1)`. ! dbvalu returns a fatal error message when `x` is outside of this ! interval. ! ! To compute left derivatives or left limiting values at a ! knot `t(i)`, replace `n` by `i-1` and set `x=t(i), i=k+1,n+1`. ! !### Error Conditions ! ! * improper input ! !### History ! * bvalue written by carl de boor [5] ! * dbvalu author: amos, d. e., (snla) : date written 800901 ! * revision date 820801 ! * 000330 modified array declarations. (jec) ! * Jacob Williams, 2/24/2015 : extensive refactoring of CMLIB routine. pure subroutine dbvalu(t,a,n,k,ideriv,x,inbv,work,iflag,val,extrap) implicit none real(wp),intent(out) :: val !! the interpolated value integer(ip),intent(in) :: n !! number of b-spline coefficients. !! (sum of knot multiplicities-`k`) real(wp),dimension(:),intent(in) :: t !! knot vector of length `n+k` real(wp),dimension(n),intent(in) :: a !! b-spline coefficient vector of length `n` integer(ip),intent(in) :: k !! order of the b-spline, `k >= 1` integer(ip),intent(in) :: ideriv !! order of the derivative, `0 <= ideriv <= k-1`. !! `ideriv = 0` returns the b-spline value real(wp),intent(in) :: x !! argument, `t(k) <= x <= t(n+1)` integer(ip),intent(inout) :: inbv !! an initialization parameter which must be set !! to 1 the first time [[dbvalu]] is called. !! `inbv` contains information for efficient processing !! after the initial call and `inbv` must not !! be changed by the user. distinct splines require !! distinct `inbv` parameters. real(wp),dimension(:),intent(inout) :: work !! work vector of length at least `3*k` integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 401: `k` does not satisfy `k` \( \ge \) 1 !! * 402: `n` does not satisfy `n` \( \ge \) `k` !! * 403: `ideriv` does not satisfy 0 \( \le \) `ideriv` \(<\) `k` !! * 404: `x` is not greater than or equal to `t(k)` !! * 405: `x` is not less than or equal to `t(n+1)` !! * 406: a left limiting value cannot be obtained at `t(k)` logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: i,iderp1,ihi,ihmkmj,ilo,imk,imkpj,ipj,& ip1,ip1mj,j,jj,j1,j2,kmider,kmj,km1,kpk,mflag real(wp) :: fkmj real(wp) :: xt logical :: extrapolation_allowed !! if extrapolation is allowed val = 0.0_wp if (k<1_ip) then iflag = 401_ip ! dbvalu - k does not satisfy k>=1 return end if if (n<k) then iflag = 402_ip ! dbvalu - n does not satisfy n>=k return end if if (ideriv<0_ip .or. ideriv>=k) then iflag = 403_ip ! dbvalu - ideriv does not satisfy 0<=ideriv<k return end if if (present(extrap)) then extrapolation_allowed = extrap else extrapolation_allowed = .false. end if ! make a temp copy of x (for computing the ! interval) in case extrapolation is allowed if (extrapolation_allowed) then if (x<t(k)) then xt = t(k) else if (x>t(n+1_ip)) then xt = t(n+1_ip) else xt = x end if else xt = x end if kmider = k - ideriv ! find *i* in (k,n) such that t(i) <= x < t(i+1) ! (or, <= t(i+1) if t(i) < t(i+1) = t(n+1)). km1 = k - 1_ip call dintrv(t, n+1, xt, inbv, i, mflag) if (xt<t(k)) then iflag = 404_ip ! dbvalu - x is not greater than or equal to t(k) return end if if (mflag/=0_ip) then if (xt>t(i)) then iflag = 405_ip ! dbvalu - x is not less than or equal to t(n+1) return end if do if (i==k) then iflag = 406_ip ! dbvalu - a left limiting value cannot be obtained at t(k) return end if i = i - 1_ip if (xt/=t(i)) exit end do end if ! difference the coefficients *ideriv* times ! work(i) = aj(i), work(k+i) = dp(i), work(k+k+i) = dm(i), i=1.k imk = i - k do j=1_ip,k imkpj = imk + j work(j) = a(imkpj) end do if (ideriv/=0_ip) then do j=1_ip,ideriv kmj = k - j fkmj = real(kmj,wp) do jj=1_ip,kmj ihi = i + jj ihmkmj = ihi - kmj work(jj) = (work(jj+1_ip)-work(jj))/(t(ihi)-t(ihmkmj))*fkmj end do end do end if ! compute value at *x* in (t(i),(t(i+1)) of ideriv-th derivative, ! given its relevant b-spline coeff. in aj(1),...,aj(k-ideriv). if (ideriv/=km1) then ip1 = i + 1_ip kpk = k + k j1 = k + 1_ip j2 = kpk + 1_ip do j=1_ip,kmider ipj = i + j work(j1) = t(ipj) - x ip1mj = ip1 - j work(j2) = x - t(ip1mj) j1 = j1 + 1_ip j2 = j2 + 1_ip end do iderp1 = ideriv + 1_ip do j=iderp1,km1 kmj = k - j ilo = kmj do jj=1_ip,kmj work(jj) = (work(jj+1_ip)*work(kpk+ilo)+work(jj)*& work(k+jj))/(work(kpk+ilo)+work(k+jj)) ilo = ilo - 1 end do end do end if iflag = 0_ip val = work(1_ip) end subroutine dbvalu !***************************************************************************************** !***************************************************************************************** !> ! Computes the interval index `left` and weights `b` such that the ! `ideriv`-th derivative of the b-spline (`t`,`a`,`n`,`k`) at `x` is ! !```fortran ! sum(b(1:k)*a(left-k+1:left)) !``` ! ! This gives the same result as [[dbvalu]], but since the weights only ! depend on the knots, they can be reused for every coefficient vector ! with the same knots. This is used by the multidimensional `db*val` ! routines so that the work in each direction is only done once. ! ! The interval selection (including left limiting values at `t(n+1)`), ! extrapolation behavior, and error codes are the same as [[dbvalu]]. pure subroutine dbvalu_weights(t,n,k,ideriv,x,inbv,left,b,iflag,extrap) implicit none real(wp),dimension(:),intent(in) :: t !! knot vector of length `n+k` integer(ip),intent(in) :: n !! number of b-spline coefficients. integer(ip),intent(in) :: k !! order of the b-spline, `k >= 1` integer(ip),intent(in) :: ideriv !! order of the derivative, `0 <= ideriv <= k-1`. real(wp),intent(in) :: x !! argument, `t(k) <= x <= t(n+1)` !! (unless extrapolation is allowed) integer(ip),intent(inout) :: inbv !! an initialization parameter which must be set !! to 1 the first time this routine is called. !! (see [[dbvalu]]) integer(ip),intent(out) :: left !! the interval index, `k <= left <= n` real(wp),dimension(k),intent(out) :: b !! weights for coefficients `left-k+1:left` integer(ip),intent(out) :: iflag !! status flag (same codes as [[dbvalu]]) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: i,j,jj,kmider,kmj,mflag real(wp) :: xt,saved,term,fac real(wp),dimension(k) :: dr !! `t(i+j) - x` real(wp),dimension(k) :: dl !! `x - t(i+1-j)` logical :: extrapolation_allowed !! if extrapolation is allowed b = 0.0_wp left = k if (k<1_ip) then iflag = 401_ip ! k does not satisfy k>=1 return end if if (n<k) then iflag = 402_ip ! n does not satisfy n>=k return end if if (ideriv<0_ip .or. ideriv>=k) then iflag = 403_ip ! ideriv does not satisfy 0<=ideriv<k return end if if (present(extrap)) then extrapolation_allowed = extrap else extrapolation_allowed = .false. end if ! temp copy of x for computing the interval ! (clamped if extrapolation is allowed) xt = x if (extrapolation_allowed) xt = min(max(x,t(k)),t(n+1_ip)) ! find *i* in (k,n) such that t(i) <= x < t(i+1) ! (or, <= t(i+1) if t(i) < t(i+1) = t(n+1)). call dintrv(t, n+1_ip, xt, inbv, i, mflag) if (xt<t(k)) then iflag = 404_ip ! x is not greater than or equal to t(k) return end if if (mflag/=0_ip) then if (xt>t(i)) then iflag = 405_ip ! x is not less than or equal to t(n+1) return end if do if (i==k) then iflag = 406_ip ! a left limiting value cannot be obtained at t(k) return end if i = i - 1_ip if (xt/=t(i)) exit end do end if ! values at x of the k-ideriv nonzero b-splines of order k-ideriv ! (the recurrence is a polynomial in x, so this also works when extrapolating) kmider = k - ideriv b(1_ip) = 1.0_wp do j=1_ip,kmider-1_ip dr(j) = t(i+j) - x dl(j) = x - t(i+1_ip-j) saved = 0.0_wp do jj=1_ip,j term = b(jj)/(dr(jj)+dl(j+1_ip-jj)) b(jj) = saved + dr(jj)*term saved = dl(j+1_ip-jj)*term end do b(j+1_ip) = saved end do ! apply the transpose of the coefficient differencing in [[dbvalu]] ! so the weights apply to the original coefficients do j=ideriv,1_ip,-1_ip kmj = k - j b(kmj+1_ip) = 0.0_wp do jj=kmj,1_ip,-1_ip fac = b(jj)*real(kmj,wp)/(t(i+jj)-t(i+jj-kmj)) b(jj+1_ip) = b(jj+1_ip) + fac b(jj) = -fac end do end do left = i iflag = 0_ip end subroutine dbvalu_weights !***************************************************************************************** !***************************************************************************************** !> ! Computes the largest integer `ileft` in 1 \( \le \) `ileft` \( \le \) `lxt` ! such that `xt(ileft)` \( \le \) `x` where `xt(*)` is a subdivision of ! the `x` interval. ! precisely, ! !```fortran ! if x < xt(1) then ileft=1, mflag=-1 ! if xt(i) <= x < xt(i+1) then ileft=i, mflag=0 ! if xt(lxt) <= x then ileft=lxt, mflag=-2 !``` ! ! that is, when multiplicities are present in the break point ! to the left of `x`, the largest index is taken for `ileft`. ! !### History ! * interv written by carl de boor [5] ! * dintrv author: amos, d. e., (snla) : date written 800901 ! * revision date 820801 ! * Jacob Williams, 2/24/2015 : updated to free-form Fortran. ! * Jacob Williams, 2/17/2016 : additional refactoring (eliminated GOTOs). ! * Jacob Williams, 3/4/2017 : added extrapolation option. pure subroutine dintrv(xt,lxt,xx,ilo,ileft,mflag,extrap) implicit none integer(ip),intent(in) :: lxt !! length of the `xt` vector real(wp),dimension(:),intent(in) :: xt !! a knot or break point vector of length `lxt` real(wp),intent(in) :: xx !! argument integer(ip),intent(inout) :: ilo !! an initialization parameter which must be set !! to 1 the first time the spline array `xt` is !! processed by dintrv. `ilo` contains information for !! efficient processing after the initial call and `ilo` !! must not be changed by the user. distinct splines !! require distinct `ilo` parameters. integer(ip),intent(out) :: ileft !! largest integer satisfying `xt(ileft)` \( \le \) `x` integer(ip),intent(out) :: mflag !! signals when `x` lies out of bounds logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) integer(ip) :: ihi, istep, middle real(wp) :: x x = get_temp_x_for_extrap(xx,xt(1_ip),xt(lxt),extrap) ihi = ilo + 1_ip if ( ihi>=lxt ) then if ( x>=xt(lxt) ) then mflag = -2_ip ileft = lxt return end if if ( lxt<=1 ) then mflag = -1_ip ileft = 1_ip return end if ilo = lxt - 1_ip ihi = lxt end if if ( x>=xt(ihi) ) then ! now x >= xt(ilo). find upper bound istep = 1_ip do ilo = ihi ihi = ilo + istep if ( ihi>=lxt ) then if ( x>=xt(lxt) ) then mflag = -2_ip ileft = lxt return end if ihi = lxt else if ( x>=xt(ihi) ) then istep = istep*2_ip cycle end if exit end do else if ( x>=xt(ilo) ) then mflag = 0_ip ileft = ilo return end if ! now x <= xt(ihi). find lower bound istep = 1_ip do ihi = ilo ilo = ihi - istep if ( ilo<=1_ip ) then ilo = 1_ip if ( x<xt(1_ip) ) then mflag = -1_ip ileft = 1_ip return end if else if ( x<xt(ilo) ) then istep = istep*2_ip cycle end if exit end do end if ! now xt(ilo) <= x < xt(ihi). narrow the interval do middle = (ilo+ihi)/2_ip if ( middle==ilo ) then mflag = 0_ip ileft = ilo return end if ! note. it is assumed that middle = ilo in case ihi = ilo+1 if ( x<xt(middle) ) then ihi = middle else ilo = middle end if end do end subroutine dintrv !***************************************************************************************** !***************************************************************************************** !> ! DBINT4 computes the B representation (`t`,`bcoef`,`n`,`k`) of a ! spline of order `k` which interpolates data (`x(i)`,`y(i)`),`i=1,ndata`. ! ! Parameters `ibcl`, `ibcr`, `fbcl`, `fbcr` allow the specification of one ! derivative of the spline (of order `1` to `k-1`) at both `x(1)` and `x(ndata)`. ! When this data is not specified by the problem, it is common practice to use ! a natural spline by setting second derivatives at `x(1)` and `x(ndata)` to zero ! (`ibcl=ibcr=2`,`fbcl=fbcr=0.0`). ! ! The spline has `n=ndata+2` coefficients and is defined on `t(k) <= x <= t(n+1)`, ! where `t(k)=x(1)` and `t(n+1)=x(ndata)`. The interior knots are placed at the ! interior `x(i)` values for even `k`, and at midpoints between them for odd `k` ! (for `k=4` the interior knots are `x(2),...,x(ndata-1)`). ! The knots `t(1),...,t(k-1)` lie to the left of `t(k)=x(1)` and the knots ! `t(n+2),...,t(n+k)` lie to the right of `t(n+1)=x(ndata)` in increasing order. ! ! * If no extrapolation outside (`x(1)`,`x(ndata)`) is anticipated, the ! knots `t(1)=...=t(k)=x(1)` and `t(n+1)=...=t(n+k)=x(ndata)` ! can be specified by `kntopt=1`. ! * `kntopt=2` selects a knot placement for `t(1),...,t(k-1)` to make the ! first `2k-1` knots symmetric about `t(k)=x(1)` and similarly for ! `t(n+2),...,t(n+k)` about `t(n+1)=x(ndata)`. ! * `kntopt=3` allows the user to make their own selection, in increasing order, ! for `t(1),...,t(k-1)` to the left of `x(1)` and `t(n+2),...,t(n+k)` to ! the right of `x(ndata)`. ! ! In any case, the interpolation on `t(k) <= x <= t(n+1)` ! by using function [[dbvalu]] is unique for given boundary ! conditions. ! !### Error conditions ! * improper input ! * singular system of equations ! !### See also ! * [[dbintk]] ! !### History ! * Written by D. E. Amos (SNLA), August, 1979. ! * date written 800901 ! * revision date 820801 ! * 000330 Modified array declarations. (JEC) ! * Jacob Williams, 8/30/2018 : refactored to modern Fortran. ! * Generalized from cubic (`k=4`) to any order `k >= 3`. pure subroutine dbint4(x,y,ndata,ibcl,ibcr,fbcl,fbcr,kntopt,tleft,tright,t,bcoef,n,k,iflag) implicit none real(wp),dimension(:),intent(in) :: x !! x vector of abscissae of length `ndata`, distinct !! and in increasing order real(wp),dimension(:),intent(in) :: y !! y vector of ordinates of length ndata integer(ip),intent(in) :: ndata !! number of data points, `ndata >= max(2,k-2)` integer(ip),intent(in) :: ibcl !! selection parameter for left boundary condition: !! constrain the `ibcl`-th derivative at `x(1)` to `fbcl` !! (`1 <= ibcl <= k-1`) integer(ip),intent(in) :: ibcr !! selection parameter for right boundary condition: !! constrain the `ibcr`-th derivative at `x(ndata)` to `fbcr` !! (`1 <= ibcr <= k-1`) real(wp),intent(in) :: fbcl !! left boundary values governed by `ibcl` real(wp),intent(in) :: fbcr !! right boundary values governed by `ibcr` integer(ip),intent(in) :: kntopt !! knot selection parameter: !! !! * `kntopt = 1` sets knot multiplicity at `t(k)` and !! `t(n+1)` to `k` !! * `kntopt = 2` sets a symmetric placement of knots !! about `t(k)` and `t(n+1)` !! * `kntopt = 3` sets `t(i)=tleft(i)` and !! `t(n+1+i)=tright(i)`,`i=1,k-1` real(wp),dimension(:),intent(in) :: tleft !! when `kntopt = 3`: `t(1:k-1)` in increasing !! order to be supplied by the user. !! (not used for other `kntopt` values) real(wp),dimension(:),intent(in) :: tright !! when `kntopt = 3`: `t(n+2:n+k)` in increasing !! order to be supplied by the user. !! (not used for other `kntopt` values) real(wp),dimension(:),intent(out) :: t !! knot array of length `n+k` real(wp),dimension(:),intent(out) :: bcoef !! b spline coefficient array of length `n` integer(ip),intent(out) :: n !! number of coefficients, `n=ndata+2` integer(ip),intent(in) :: k !! order of spline, `k >= 3` integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 806: `k` is less than 3 !! * 2001: `ndata` is less than `max(2,k-2)` !! * 2002: `x` values are not distinct or not ordered !! * 2003: `ibcl` is not in the range `1` to `k-1` !! * 2004: `ibcr` is not in the range `1` to `k-1` !! * 2005: `kntopt` is not 1, 2, or 3 !! * 2006: knot input through `tleft`, `tright` is !! not ordered properly !! * 2007: the system of equations is singular !! * 2008: `tleft` or `tright` does not have size `k-1` integer(ip) :: i, j, ilo, mflag, np, ml, mu, m, nderiv, icol real(wp) :: xl, rowmax real(wp),dimension(:),allocatable :: tau !! abscissa of each equation integer(ip),dimension(:),allocatable :: ider !! derivative order of each equation integer(ip),dimension(:),allocatable :: ileft !! knot interval of each equation real(wp),dimension(:,:),allocatable :: abd !! banded matrix of the system integer(ip),dimension(:),allocatable :: ipvt !! pivot indices real(wp),dimension(:,:),allocatable :: vnikx !! basis function values from [[dbspvd]] real(wp),dimension(:),allocatable :: work !! work array for [[dbspvd]] real(wp),dimension(:),allocatable :: colmax !! scale factor of each column of the system n = ndata + 2_ip if (k<3_ip) then iflag = 806_ip ! k is less than 3 return end if if (ndata<max(2_ip,k-2_ip)) then iflag = 2001_ip ! ndata is less than max(2,k-2) return end if do i=1_ip,ndata-1_ip if (x(i)>=x(i+1_ip)) then iflag = 2002_ip ! x values are not distinct or not ordered return end if end do if (ibcl<1_ip .or. ibcl>k-1_ip) then iflag = 2003_ip ! ibcl is not in the range 1 to k-1 return end if if (ibcr<1_ip .or. ibcr>k-1_ip) then iflag = 2004_ip ! ibcr is not in the range 1 to k-1 return end if if (kntopt<1_ip .or. kntopt>3_ip) then iflag = 2005_ip ! kntopt is not 1, 2, or 3 return end if if (kntopt==3_ip) then if (size(tleft,kind=ip)/=k-1_ip .or. size(tright,kind=ip)/=k-1_ip) then iflag = 2008_ip ! tleft or tright does not have size k-1 return end if end if iflag = 0_ip np = n + 1_ip ! the equations, in order: f(x(1)), the left boundary condition, ! f(x(2)),...,f(x(ndata-1)), the right boundary condition, f(x(ndata)) allocate(tau(n), ider(n), ileft(n)) tau(1:2) = x(1) tau(3:ndata) = x(2:ndata-1) tau(n-1:n) = x(ndata) ider = 0_ip ider(2) = ibcl ider(n-1) = ibcr ! interior knots, centered on the equation abscissae t(k) = x(1) t(np) = x(ndata) do i=1_ip,n-k if (mod(k,2_ip)==0_ip) then t(k+i) = tau(i+k/2_ip) else t(k+i) = 0.5_wp*(tau(i+(k-1_ip)/2_ip)+tau(i+(k+1_ip)/2_ip)) end if end do select case (kntopt) case(1_ip) ! set up knot array with multiplicity k at x(1) and x(ndata) do i=1_ip,k-1_ip t(k-i) = x(1) t(np+i) = x(ndata) end do case(2_ip) ! set up knot array with symmetric placement about end points if (n>=2_ip*k-2_ip) then do i=1_ip,k-1_ip t(k-i) = 2.0_wp*t(k) - t(k+i) t(np+i) = 2.0_wp*t(np) - t(np-i) end do else xl = (x(ndata)-x(1))/real(k-1_ip,wp) do i=1_ip,k-1_ip t(k-i) = t(k-i+1_ip) - xl t(np+i) = t(np+i-1_ip) + xl end do end if case(3_ip) ! set up knot array less than x(1) and greater than x(ndata) to be ! supplied by user in tleft & tright when kntopt=3 t(1:k-1) = tleft t(n+2:n+k) = tright do i=1_ip,k-1_ip if ((t(k-i)>t(k-i+1_ip)) .or. (t(np+i)<t(np+i-1_ip))) then iflag = 2006_ip ! knot input through tleft, tright is not ordered properly return end if end do end select ! knot interval for each equation. right limits at x(1) and ! left limits at x(ndata), so the end intervals are k and n. ilo = 1_ip do i=1_ip,n if (i<=2_ip) then ileft(i) = k else if (i>=n-1_ip) then ileft(i) = n else call dintrv(t,np,tau(i),ilo,ileft(i),mflag) end if end do ! bandwidth of the system (row i has nonzeros in columns ileft-k+1:ileft) ml = 0_ip mu = 0_ip do i=1_ip,n ml = max(ml, i-(ileft(i)-k+1_ip)) mu = max(mu, ileft(i)-i) end do m = ml + mu + 1_ip ! set up the banded system: A(i,j) is stored in abd(i-j+m,j) allocate(abd(2_ip*ml+mu+1_ip,n), ipvt(n)) allocate(vnikx(k,k), work((k+1_ip)*(k+2_ip)/2_ip)) ! right hand side bcoef(1) = y(1) bcoef(2) = fbcl bcoef(3:ndata) = y(2:ndata-1) bcoef(n-1) = fbcr bcoef(n) = y(ndata) abd = 0.0_wp do i=1_ip,n nderiv = ider(i) + 1_ip call dbspvd(t,k,nderiv,tau(i),ileft(i),k,vnikx,work,iflag) if (iflag/=0_ip) return ! scale each equation by its largest coefficient, since the derivative ! rows can be orders of magnitude larger than the interpolation rows rowmax = maxval(abs(vnikx(:,nderiv))) if (rowmax==0.0_wp) rowmax = 1.0_wp do j=1_ip,k icol = ileft(i) - k + j abd(i-icol+m,icol) = vnikx(j,nderiv) / rowmax end do bcoef(i) = bcoef(i) / rowmax end do ! also scale each column (unknown), since a basis function can be small ! at all of the data points (e.g., when the data spacing near an end is ! very uneven), and its pivot would then look singular. The scale factors ! are the largest powers of 2 not greater than the largest entry of each ! column, so the scaling is exact and does not change the solution (partial ! pivoting is not affected by column scaling), and does not enlarge the ! scaled solution (which could overflow). The solution is unscaled below. allocate(colmax(n)) do j=1_ip,n colmax(j) = maxval(abs(abd(:,j))) if (colmax(j)==0.0_wp) then colmax(j) = 1.0_wp else colmax(j) = scale(1.0_wp, exponent(colmax(j))-1) end if abd(:,j) = abd(:,j) / colmax(j) end do ! solve system of equations ! (the rows and columns are scaled so the largest entry of each is about 1, ! so an absolute tolerance on the pivots detects a numerically singular system) call dgbfa(abd,n,ml,mu,ipvt,1000.0_wp*epsilon(1.0_wp),iflag) if (iflag/=0_ip) then iflag = 2007_ip ! the system of equations is singular else call dgbsl(abd,n,ml,mu,ipvt,bcoef(1:n)) bcoef(1:n) = bcoef(1:n) / colmax end if end subroutine dbint4 !***************************************************************************************** !***************************************************************************************** !> ! Factors a banded matrix by Gaussian elimination with partial pivoting. ! The matrix `A` is stored in `abd` with `A(i,j)` in `abd(i-j+ml+mu+1,j)`. ! Rows `1:ml` of `abd` are used for the fill-in generated by pivoting. ! !### History ! * Based on the LINPACK routine `DGBFA` (Cleve Moler, 1978). ! Added the `tol` argument for detecting singular matrices. pure subroutine dgbfa(abd,n,ml,mu,ipvt,tol,info) implicit none integer(ip),intent(in) :: n !! order of the matrix integer(ip),intent(in) :: ml !! number of diagonals below the main diagonal integer(ip),intent(in) :: mu !! number of diagonals above the main diagonal real(wp),dimension(2_ip*ml+mu+1_ip,n),intent(inout) :: abd !! **IN:** the matrix in band storage. !! **OUT:** its LU factorization. integer(ip),dimension(n),intent(out) :: ipvt !! pivot indices real(wp),intent(in) :: tol !! a pivot with `abs(u(k,k)) <= tol` is !! treated as zero (`tol=0` gives the !! original LINPACK behavior) integer(ip),intent(out) :: info !! 0 if successful, otherwise `k` if `u(k,k)` !! is zero (the matrix is singular) integer(ip) :: i, j, jk, ju, jz, l, lm, m, mm real(wp) :: tmp m = ml + mu + 1_ip info = 0_ip ! zero the initial fill-in columns do jz = mu+2_ip, min(n,m)-1_ip abd(m+1_ip-jz:ml,jz) = 0.0_wp end do jz = min(n,m) - 1_ip ju = 0_ip do jk = 1_ip, n-1_ip ! zero the next fill-in column jz = jz + 1_ip if (jz<=n .and. ml>=1_ip) abd(1:ml,jz) = 0.0_wp ! find the pivot lm = min(ml,n-jk) l = maxloc(abs(abd(m:m+lm,jk)),dim=1,kind=ip) + m - 1_ip ipvt(jk) = l + jk - m if (abs(abd(l,jk))<=tol) then ! this column is already triangularized info = jk cycle end if ! interchange if necessary if (l/=m) then tmp = abd(l,jk) abd(l,jk) = abd(m,jk) abd(m,jk) = tmp end if ! compute the multipliers abd(m+1_ip:m+lm,jk) = abd(m+1_ip:m+lm,jk) * (-1.0_wp/abd(m,jk)) ! row elimination with column indexing ju = min(max(ju,mu+ipvt(jk)),n) mm = m do j = jk+1_ip, ju l = l - 1_ip mm = mm - 1_ip tmp = abd(l,j) if (l/=mm) then abd(l,j) = abd(mm,j) abd(mm,j) = tmp end if do i = 1_ip, lm abd(mm+i,j) = abd(mm+i,j) + tmp*abd(m+i,jk) end do end do end do ipvt(n) = n if (abs(abd(m,n))<=tol) info = n end subroutine dgbfa !***************************************************************************************** !***************************************************************************************** !> ! Solves the banded system `A*x = b` using the factorization from [[dgbfa]]. ! !### History ! * Based on the LINPACK routine `DGBSL` (Cleve Moler, 1978). pure subroutine dgbsl(abd,n,ml,mu,ipvt,b) implicit none integer(ip),intent(in) :: n !! order of the matrix integer(ip),intent(in) :: ml !! number of diagonals below the main diagonal integer(ip),intent(in) :: mu !! number of diagonals above the main diagonal real(wp),dimension(2_ip*ml+mu+1_ip,n),intent(in) :: abd !! the factorization from [[dgbfa]] integer(ip),dimension(n),intent(in) :: ipvt !! the pivot indices from [[dgbfa]] real(wp),dimension(n),intent(inout) :: b !! **IN:** the right hand side. !! **OUT:** the solution. integer(ip) :: i, jk, l, la, lb, lm, m real(wp) :: tmp m = mu + ml + 1_ip ! solve L*y = b if (ml/=0_ip) then do jk = 1_ip, n-1_ip lm = min(ml,n-jk) l = ipvt(jk) tmp = b(l) if (l/=jk) then b(l) = b(jk) b(jk) = tmp end if do i = 1_ip, lm b(jk+i) = b(jk+i) + tmp*abd(m+i,jk) end do end do end if ! solve U*x = y do jk = n, 1_ip, -1_ip b(jk) = b(jk)/abd(m,jk) lm = min(jk,m) - 1_ip la = m - lm lb = jk - lm tmp = -b(jk) do i = 0_ip, lm-1_ip b(lb+i) = b(lb+i) + tmp*abd(la+i,jk) end do end do end subroutine dgbsl !***************************************************************************************** !***************************************************************************************** !***************************************************************************************** !> ! DBSPVD calculates the value and all derivatives of order ! less than `nderiv` of all basis functions which do not ! (possibly) vanish at `x`. `ileft` is input such that ! `t(ileft) <= x < t(ileft+1)`. A call to [[dintrv]](`t`,`n+1`,`x`, ! `ilo`,`ileft`,`mflag`) will produce the proper `ileft`. The output of ! dbspvd is a matrix `vnikx(i,j)` of dimension at least `(k,nderiv)` ! whose columns contain the `k` nonzero basis functions and ! their `nderiv-1` right derivatives at `x`, `i=1,k, j=1,nderiv`. ! These basis functions have indices `ileft-k+i`, `i=1,k, ! k <= ileft <= n`. The nonzero part of the `i`-th basis ! function lies in `(t(i),t(i+k)), i=1,n)`. ! ! If `x=t(ileft+1)` then `vnikx` contains left limiting values ! (left derivatives) at `t(ileft+1)`. In particular, `ileft = n` ! produces left limiting values at the right end point ! `x=t(n+1)`. To obtain left limiting values at `t(i)`, `i=k+1,n+1`, ! set `x` = next lower distinct knot, call [[dintrv]] to get `ileft`, ! set `x=t(i)`, and then call dbspvd. ! !### History ! * Written by Carl de Boor and modified by D. E. Amos ! * date written 800901 ! * revision date 820801 ! * 000330 Modified array declarations. (JEC) ! * Jacob Williams, 8/30/2018 : refactored to modern Fortran. ! !@note `DBSPVD` is the `BSPLVD` routine of the reference. pure subroutine dbspvd(t,k,nderiv,x,ileft,ldvnik,vnikx,work,iflag) implicit none real(wp),dimension(:),intent(in) :: t !! knot vector of length `n+k`, where !! `n` = number of b-spline basis functions !! `n` = sum of knot multiplicities-k integer(ip),intent(in) :: k !! order of the b-spline, `k >= 1` integer(ip),intent(in) :: nderiv !! number of derivatives = `nderiv-1`, !! `1 <= nderiv <= k` real(wp),intent(in) :: x !! argument of basis functions, !! `t(k) <= x <= t(n+1)` integer(ip),intent(in) :: ileft !! largest integer such that !! `t(ileft) <= x < t(ileft+1)` integer(ip),intent(in) :: ldvnik !! leading dimension of matrix `vnikx` real(wp),dimension(ldvnik,nderiv),intent(out) :: vnikx !! matrix of dimension at least `(k,nderiv)` !! containing the nonzero basis functions !! at `x` and their derivatives columnwise. real(wp),dimension(*),intent(out) :: work !! a work vector of length `(k+1)*(k+2)/2` integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 3001: `k` does not satisfy `k>=1` !! * 3002: `nderiv` does not satisfy `1<=nderiv<=k` !! * 3003: `ldvnik` does not satisfy `ldvnik>=k` integer(ip) :: i,ideriv,ipkmd,j,jj,jlow,jm,jp1mid,kmd,kp1,l,ldummy,m,mhigh,iwork real(wp) :: factor, fkmd, v ! dimension t(ileft+k), work((k+1)*(k+2)/2) ! a(i,j) = work(i+j*(j+1)/2), i=1,j+1 j=1,k-1 ! a(i,k) = work(i+k*(k-1)/2) i=1.k ! work(1) and work((k+1)*(k+2)/2) are not used. if (k<1) then iflag = 3001_ip ! k does not satisfy k>=1 return end if if (nderiv<1 .or. nderiv>k) then iflag = 3002_ip ! nderiv does not satisfy 1<=nderiv<=k return end if if (ldvnik<k) then iflag = 3003_ip ! ldvnik does not satisfy ldvnik>=k return end if iflag = 0_ip ideriv = nderiv kp1 = k + 1 jj = kp1 - ideriv call dbspvn(t, jj, k, 1_ip, x, ileft, vnikx, work, iwork, iflag) if (iflag/=0 .or. ideriv==1) return mhigh = ideriv do m=2,mhigh jp1mid = 1 do j=ideriv,k vnikx(j,ideriv) = vnikx(jp1mid,1) jp1mid = jp1mid + 1 end do ideriv = ideriv - 1 jj = kp1 - ideriv call dbspvn(t, jj, k, 2_ip, x, ileft, vnikx, work, iwork, iflag) if (iflag/=0) return end do jm = kp1*(kp1+1)/2 do l = 1,jm work(l) = 0.0_wp end do ! a(i,i) = work(i*(i+3)/2) = 1.0 i = 1,k l = 2 j = 0 do i = 1,k j = j + l work(j) = 1.0_wp l = l + 1 end do kmd = k do m=2,mhigh kmd = kmd - 1 fkmd = real(kmd,wp) i = ileft j = k jj = j*(j+1)/2 jm = jj - j do ldummy=1,kmd ipkmd = i + kmd factor = fkmd/(t(ipkmd)-t(i)) do l=1,j work(l+jj) = (work(l+jj)-work(l+jm))*factor end do i = i - 1 j = j - 1 jj = jm jm = jm - j end do do i=1,k v = 0.0_wp jlow = max(i,m) jj = jlow*(jlow+1)/2 do j=jlow,k v = work(i+jj)*vnikx(j,m) + v jj = jj + j + 1 end do vnikx(i,m) = v end do end do end subroutine dbspvd !***************************************************************************************** !***************************************************************************************** !> ! DBSQAD computes the integral on `(x1,x2)` of a `k`-th order ! b-spline using the b-representation `(t,bcoef,n,k)`. orders ! `k` as high as 20 are permitted by applying a 2, 6, or 10 ! point gauss formula on subintervals of `(x1,x2)` which are ! formed by included (distinct) knots. ! ! If orders `k` greater than 20 are needed, use [[dbfqad]] with ! `f(x) = 1`. ! !### Note ! * The maximum number of significant digits obtainable in ! DBSQAD is the smaller of ~300 and the number of digits ! carried in `real(wp)` arithmetic. ! !### References ! * D. E. Amos, "Quadrature subroutines for splines and ! B-splines", Report SAND79-1825, Sandia Laboratories, ! December 1979. ! !### History ! * Author: Amos, D. E., (SNLA) ! * 800901 DATE WRITTEN ! * 890531 Changed all specific intrinsics to generic. (WRB) ! * 890531 REVISION DATE from Version 3.2 ! * 891214 Prologue converted to Version 4.0 format. (BAB) ! * 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! * 900326 Removed duplicate information from DESCRIPTION section. (WRB) ! * 920501 Reformatted the REFERENCES section. (WRB) ! * Jacob Williams, 9/6/2017 : refactored to modern Fortran. ! Added higher precision coefficients. ! !@note Extrapolation is not enabled for this routine. pure subroutine dbsqad(t,bcoef,n,k,x1,x2,bquad,work,iflag) implicit none real(wp),dimension(:),intent(in) :: t !! knot array of length `n+k` real(wp),dimension(:),intent(in) :: bcoef !! b-spline coefficient array of length `n` integer(ip),intent(in) :: n !! length of coefficient array integer(ip),intent(in) :: k !! order of b-spline, `1 <= k <= 20` real(wp),intent(in) :: x1 !! end point of quadrature interval !! in `t(k) <= x <= t(n+1)` real(wp),intent(in) :: x2 !! end point of quadrature interval !! in `t(k) <= x <= t(n+1)` real(wp),intent(out) :: bquad !! integral of the b-spline over (`x1`,`x2`) real(wp),dimension(:),intent(inout) :: work !! work vector of length `3*k` integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 901: `k` does not satisfy `1<=k<=20` !! * 902: `n` does not satisfy `n>=k` !! * 903: `x1` or `x2` or both do !! not satisfy `t(k)<=x<=t(n+1)` integer(ip) :: i,il1,il2,ilo,inbv,jf,left,m,mf,mflag,npk,np1 real(wp) :: a,aa,b,bb,bma,bpa,c1,gx,q,ta,tb,y1,y2 real(wp),dimension(5) :: s !! sum real(wp),dimension(9),parameter :: gpts = [ & &0.577350269189625764509148780501957455647601751270126876018602326483977& &67230293334569371539558574952522520871380513556767665664836499965082627& &05518373647912161760310773007685273559916067003615583077550051041144223& &01107628883557418222973945990409015710553455953862673016662179126619796& &4892168_wp,& &0.238619186083196908630501721680711935418610630140021350181395164574274& &93427563984224922442725734913160907222309701068720295545303507720513526& &28872175189982985139866216812636229030578298770859440976999298617585739& &46921613621659222233462641640013936777894532787145324672151888999339900& &0945406150514997832_wp,& &0.661209386466264513661399595019905347006448564395170070814526705852183& &49660714310094428640374646145642988837163927514667955734677222538043817& &23198010093367423918538864300079016299442625145884902455718821970386303& &22362011735232135702218793618906974301231555871064213101639896769013566& &1651261150514997832_wp,& &0.932469514203152027812301554493994609134765737712289824872549616526613& &50084420019627628873992192598504786367972657283410658797137951163840419& &21786180750210169211578452038930846310372961174632524612619760497437974& &07422632089671621172178385230505104744277222209386367655366917903888025& &2326771150514997832_wp,& &0.148874338981631210884826001129719984617564859420691695707989253515903& &61735566852137117762979946369123003116080525533882610289018186437654023& &16761969968090913050737827720371059070942475859422743249837177174247346& &21691485290294292900319346665908243383809435507599683357023000500383728& &0634351_wp,& &0.433395394129247190799265943165784162200071837656246496502701513143766& &98907770350122510275795011772122368293504099893794727422475772324920512& &67741032822086200952319270933462032011328320387691584063411149801129823& &14148878744320432476641442157678880770848387945248811854979703928792696& &4254222_wp,& &0.679409568299024406234327365114873575769294711834809467664817188952558& &57539507492461507857357048037949983390204739931506083674084257663009076& &82741718202923543197852846977409718369143712013552962837733153108679126& &93254495485472934132472721168027426848661712101171203022718105101071880& &4444161_wp,& &0.865063366688984510732096688423493048527543014965330452521959731845374& &75513805556135679072894604577069440463108641176516867830016149345356373& &92729396890950011571349689893051612072435760480900979725923317923795535& &73929059587977695683242770223694276591148364371481692378170157259728913& &9322313_wp,& &0.973906528517171720077964012084452053428269946692382119231212066696595& &20323463615962572356495626855625823304251877421121502216860143447777992& &05409587259942436704413695764881258799146633143510758737119877875210567& &06745243536871368303386090938831164665358170712568697066873725922944928& &4383797_wp] real(wp),dimension(9),parameter :: gwts = [ & &1.0_wp,& &0.467913934572691047389870343989550994811655605769210535311625319963914& &20162039812703111009258479198230476626878975479710092836255417350295459& &35635592733866593364825926382559018030281273563502536241704619318259000& &99756987095900533474080074634376824431808173206369174103416261765346292& &7888917150514997832_wp,& &0.360761573048138607569833513837716111661521892746745482289739240237140& &03783726171832096220198881934794311720914037079858987989027836432107077& &67872114085818922114502722525757771126000732368828591631602895111800517& &40813685547074482472486101183259931449817216402425586777526768199930950& &3106873150514997832_wp,& &0.171324492379170345040296142172732893526822501484043982398635439798945& &76054234015464792770542638866975211652206987440430919174716746217597462& &96492293180314484520671351091683210843717994067668872126692485569940481& &59429327357024984053433824182363244118374610391205239119044219703570297& &7497812150514997832_wp,& &0.295524224714752870173892994651338329421046717026853601354308029755995& &93821715232927035659579375421672271716440125255838681849078955200582600& &19363424941869666095627186488841680432313050615358674090830512706638652& &87483901746874726597515954450775158914556548308329986393605934912382356& &670244_wp,& &0.269266719309996355091226921569469352859759938460883795800563276242153& &43231917927676422663670925276075559581145036869830869292346938114524155& &64658846634423711656014432259960141729044528030344411297902977067142537& &53480628460839927657500691168674984281408628886853320804215041950888191& &6391898_wp,& &0.219086362515982043995534934228163192458771870522677089880956543635199& &91065295128124268399317720219278659121687281288763476662690806694756883& &09211843316656677105269915322077536772652826671027878246851010208832173& &32006427348325475625066841588534942071161341022729156547776892831330068& &8702802_wp,& &0.149451349150580593145776339657697332402556639669427367835477268753238& &65472663001094594726463473195191400575256104543633823445170674549760147& &13716011937109528798134828865118770953566439639333773939909201690204649& &08381561877915752257830034342778536175692764212879241228297015017259084& &2897331_wp,& &0.066671344308688137593568809893331792857864834320158145128694881613412& &06408408710177678550968505887782109005471452041933148750712625440376213& &93049873169940416344953637064001870112423155043935262424506298327181987& &18647480566044117862086478449236378557180717569208295026105115288152794& &421677_wp] iflag = 0_ip bquad = 0.0_wp if ( k<1_ip .or. k>20_ip ) then iflag = 901_ip ! error return else if ( n<k ) then iflag = 902_ip ! error return else aa = min(x1,x2) bb = max(x1,x2) if ( aa>=t(k) ) then np1 = n + 1_ip if ( bb<=t(np1) ) then if ( aa==bb ) return npk = n + k ! selection of 2, 6, or 10 point gauss formula jf = 0_ip mf = 1_ip if ( k>4_ip ) then jf = 1_ip mf = 3_ip if ( k>12_ip ) then jf = 4_ip mf = 5_ip end if end if do i = 1_ip , mf s(i) = 0.0_wp end do ilo = 1_ip inbv = 1_ip call dintrv(t,npk,aa,ilo,il1,mflag) call dintrv(t,npk,bb,ilo,il2,mflag) if ( il2>=np1 ) il2 = n do left = il1 , il2 ta = t(left) tb = t(left+1_ip) if ( ta/=tb ) then a = max(aa,ta) b = min(bb,tb) bma = 0.5_wp*(b-a) bpa = 0.5_wp*(b+a) do m = 1_ip , mf c1 = bma*gpts(jf+m) gx = -c1 + bpa call dbvalu(t,bcoef,n,k,0_ip,gx,inbv,work,iflag,y2) if (iflag/=0_ip) return gx = c1 + bpa call dbvalu(t,bcoef,n,k,0_ip,gx,inbv,work,iflag,y1) if (iflag/=0_ip) return s(m) = s(m) + (y1+y2)*bma end do end if end do q = 0.0_wp do m = 1_ip , mf q = q + gwts(jf+m)*s(m) end do if ( x1>x2 ) q = -q bquad = q return end if end if iflag = 903_ip ! error return end if end subroutine dbsqad !***************************************************************************************** !***************************************************************************************** !> ! dbfqad computes the integral on `(x1,x2)` of a product of a ! function `f` and the `id`-th derivative of a `k`-th order b-spline, ! using the b-representation `(t,bcoef,n,k)`. `(x1,x2)` must be a ! subinterval of `t(k) <= x <= t(n+1)`. an integration routine, ! [[dbsgq8]] (a modification of `gaus8`), integrates the product ! on subintervals of `(x1,x2)` formed by included (distinct) knots ! !### Reference ! * D. E. Amos, "Quadrature subroutines for splines and ! B-splines", Report SAND79-1825, Sandia Laboratories, ! December 1979. ! !### History ! * 800901 Amos, D. E., (SNLA) ! * 890531 Changed all specific intrinsics to generic. (WRB) ! * 890531 REVISION DATE from Version 3.2 ! * 891214 Prologue converted to Version 4.0 format. (BAB) ! * 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! * 900326 Removed duplicate information from DESCRIPTION section. (WRB) ! * 920501 Reformatted the REFERENCES section. (WRB) ! * Jacob Williams, 9/6/2017 : refactored to modern Fortran. Some changes. ! !@note the maximum number of significant digits obtainable in ! [[dbsqad]] is the smaller of ~300 and the number of digits ! carried in `real(wp)` arithmetic. ! !@note Extrapolation is not enabled for this routine. subroutine dbfqad(f,t,bcoef,n,k,id,x1,x2,tol,quad,iflag,work) implicit none procedure(b1fqad_func) :: f !! external function of one argument for the !! integrand `bf(x)=f(x)*dbvalu(t,bcoef,n,k,id,x,inbv,work)` integer(ip),intent(in) :: n !! length of coefficient array integer(ip),intent(in) :: k !! order of b-spline, `k >= 1` real(wp),dimension(n+k),intent(in) :: t !! knot array real(wp),dimension(n),intent(in) :: bcoef !! coefficient array integer(ip),intent(in) :: id !! order of the spline derivative, `0 <= id <= k-1` !! `id=0` gives the spline function real(wp),intent(in) :: x1 !! left point of quadrature interval in `t(k) <= x <= t(n+1)` real(wp),intent(in) :: x2 !! right point of quadrature interval in `t(k) <= x <= t(n+1)` real(wp),intent(in) :: tol !! desired accuracy for the quadrature, suggest !! `10*dtol < tol <= 0.1` where `dtol` is the maximum !! of `1.0e-300` and real(wp) unit roundoff for !! the machine real(wp),intent(out) :: quad !! integral of `bf(x)` on `(x1,x2)` real(wp),dimension(:),intent(inout) :: work !! work vector of length `3*k` integer(ip),intent(out) :: iflag !! status flag: !! !! * 0: no errors !! * 1001: `k` does not satisfy `k>=1` !! * 1002: `n` does not satisfy `n>=k` !! * 1003: `d` does not satisfy `0<=id<k` !! * 1004: `x1` or `x2` or both do not !! satisfy `t(k)<=x<=t(n+1)` !! * 1005: `tol` is less than `dtol` !! or greater than 0.1 integer(ip) :: inbv,ilo,il1,il2,left,mflag,npk,np1 real(wp) :: a,aa,ans,b,bb,q,ta,tb,err real(wp),parameter :: min_tol = max(epsilon(1.0_wp),1.0e-300_wp) !! minimum allowed `tol` real(wp),parameter :: narrow = 2.0_wp**(-40) !! a subinterval narrower than this relative to `|x|` !! is integrated with a fixed Gauss rule iflag = 0_ip quad = 0.0_wp err = tol if ( k<1_ip ) then iflag = 1001_ip ! error else if ( n<k ) then iflag = 1002_ip ! error else if ( id<0_ip .or. id>=k ) then iflag = 1003_ip ! error else if ( tol>=min_tol .and. tol<=0.1_wp ) then aa = min(x1,x2) bb = max(x1,x2) if ( aa>=t(k) ) then np1 = n + 1_ip if ( bb<=t(np1) ) then if ( aa==bb ) return npk = n + k ilo = 1_ip call dintrv(t,npk,aa,ilo,il1,mflag) call dintrv(t,npk,bb,ilo,il2,mflag) if ( il2>=np1 ) il2 = n inbv = 1_ip q = 0.0_wp do left = il1 , il2 ta = t(left) tb = t(left+1_ip) if ( ta/=tb ) then a = max(aa,ta) b = min(bb,tb) if ( abs(b-a) <= narrow*max(abs(a),abs(b)) ) then ! too narrow relative to |x| for dbsgq8 (which returns ! 1101, or 0 if a/b rounds to 1) call gauss8(a,b,left,ans,iflag) else call dbsgq8(f,t,bcoef,n,k,id,a,b,inbv,err,ans,iflag,work) if ( iflag==1101_ip ) call gauss8(a,b,left,ans,iflag) end if if ( iflag/=0_ip ) return q = q + ans end if end do if ( x1>x2 ) q = -q quad = q else iflag = 1004_ip ! error end if else iflag = 1004_ip ! error end if else iflag = 1005_ip ! error end if end if contains subroutine gauss8(a,b,l,ans,iflag) !! 8-point Gauss-Legendre rule on `[a,b]`, for a subinterval that is too !! narrow (relative to `|x|`) for [[dbsgq8]]. `[a,b]` is inside knot !! interval `l`, where the spline is a polynomial, so the rule is exact !! for the spline part for orders up to 16 (and very accurate for a !! smooth `f` over such a narrow interval). !! !! The nodes may not be representable (the interval may be only a few !! ulps wide), so the spline is evaluated at the exact offsets from the !! midpoint, from its Taylor expansion there. `f` is evaluated at the !! nearest representable points. !! !!@note For orders above 16, the rule is not exact for the spline part !! (but is still accurate to better than about `1e-8`). The !! derivatives in the Taylor expansion can overflow if the knot !! interval is extremely small (e.g., about `1e-200` wide). real(wp),intent(in) :: a !! left end of the subinterval real(wp),intent(in) :: b !! right end of the subinterval integer(ip),intent(in) :: l !! knot interval containing `[a,b]`: `t(l) <= a < b <= t(l+1)` real(wp),intent(out) :: ans !! the integral integer(ip),intent(out) :: iflag !! status flag from [[dbspvd]] real(wp),dimension(4),parameter :: xg = [gl8_x1, gl8_x2, gl8_x3, gl8_x4] !! nodes (positive half) real(wp),dimension(4),parameter :: wg = [gl8_w1, gl8_w2, gl8_w3, gl8_w4] !! weights real(wp),dimension(k,k) :: vnikx !! basis functions and their derivatives at the midpoint real(wp),dimension((k+1)*(k+2)/2) :: wrk !! work array for [[dbspvd]] real(wp),dimension(0:k-1) :: dc !! Taylor coefficients of the spline (or its derivative) !! about the midpoint real(wp) :: c !! midpoint of the subinterval real(wp) :: h !! half width of the subinterval real(wp) :: r !! rounding error of `c` (the true midpoint is `c+r`) real(wp) :: dx !! offset of a node from `c` real(wp) :: fs !! spline (or derivative) value at a node integer(ip) :: i !! counter integer(ip) :: j !! side of the midpoint (-1 or 1) integer(ip) :: m !! degree of the Taylor expansion: `k-1-id` integer(ip) :: jj !! counter c = a + 0.5_wp*(b-a) h = 0.5_wp*(b-a) r = (a - c) + h ! the true midpoint minus the rounded one m = k - 1_ip - id call dbspvd(t,k,k,c,l,k,vnikx,wrk,iflag) if (iflag/=0_ip) return do jj = 0_ip, m dc(jj) = dot_product(vnikx(:,id+jj+1_ip), bcoef(l-k+1_ip:l)) if (jj>1_ip) dc(jj) = dc(jj) / product([(real(i,wp), i=2_ip,jj)]) end do ans = 0.0_wp do i = 1_ip, 4_ip do j = -1_ip, 1_ip, 2_ip dx = r + real(j,wp)*h*xg(i) fs = dc(m) do jj = m-1_ip, 0_ip, -1_ip fs = fs*dx + dc(jj) end do ans = ans + wg(i) * f(min(b, max(a, c + dx))) * fs end do end do ans = h * ans end subroutine gauss8 end subroutine dbfqad !***************************************************************************************** !***************************************************************************************** !> ! DBSGQ8, a modification of [gaus8](http://netlib.sandia.gov/slatec/src/gaus8.f), ! integrates the product of `fun(x)` by the `id`-th derivative of a spline ! [[dbvalu]] between limits `a` and `b` using an adaptive 8-point Legendre-Gauss ! algorithm. ! !### See also ! * [[dbfqad]] ! !### History ! * 800901 Jones, R. E., (SNLA) ! * 890531 Changed all specific intrinsics to generic. (WRB) ! * 890911 Removed unnecessary intrinsics. (WRB) ! * 891214 Prologue converted to Version 4.0 format. (BAB) ! * 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! * 900326 Removed duplicate information from DESCRIPTION section. (WRB) ! * 900328 Added TYPE section. (WRB) ! * 910408 Updated the AUTHOR section. (WRB) ! * Jacob Williams, 9/6/2017 : refactored to modern Fortran. Some changes. ! Added higher precision coefficients. subroutine dbsgq8(fun,xt,bc,n,kk,id,a,b,inbv,err,ans,iflag,work) implicit none procedure(b1fqad_func) :: fun !! name of external function of one !! argument which multiplies [[dbvalu]]. integer(ip),intent(in) :: n !! number of b-coefficients for [[dbvalu]] integer(ip),intent(in) :: kk !! order of the spline, `kk>=1` real(wp),dimension(:),intent(in) :: xt !! knot array for [[dbvalu]] real(wp),dimension(n),intent(in) :: bc !! b-coefficient array for [[dbvalu]] integer(ip),intent(in) :: id !! Order of the spline derivative, `0<=id<=kk-1` real(wp),intent(in) :: a !! lower limit of integral real(wp),intent(in) :: b !! upper limit of integral (may be less than `a`) integer(ip),intent(inout) :: inbv !! initialization parameter for [[dbvalu]] real(wp),intent(inout) :: err !! **IN:** is a requested pseudorelative error !! tolerance. normally pick a value of !! `abs(err)<1e-3`. `ans` will normally !! have no more error than `abs(err)` times !! the integral of the absolute value of !! `fun(x)*[[dbvalu]]()`. !! !! **OUT:** will be an estimate of the absolute !! error in ans if the input value of `err` !! was negative. (`err` is unchanged if !! the input value of `err` was nonnegative.) !! the estimated error is solely for information !! to the user and should not be used as a !! correction to the computed integral. real(wp),intent(out) :: ans !! computed value of integral integer(ip),intent(out) :: iflag !! a status code: !! !! * 0: `ans` most likely meets requested !! error tolerance, or `a=b`. !! * 1101: `a` and `b` are too nearly equal !! to allow normal integration. !! `ans` is set to zero. !! * 1102: `ans` probably does not meet !! requested error tolerance. real(wp),dimension(:),intent(inout) :: work !! work vector of length `3*k` for [[dbvalu]] integer(ip) :: k,l,lmn,lmx,mxl,nbits,nib,nlmx real(wp) :: ae,anib,area,c,ce,ee,ef,eps,est,gl,glr,tol,vr,x integer(ip),dimension(60) :: lr real(wp),dimension(60) :: aa,hh,vl,gr integer(ip),parameter :: i1mach14 = digits(1.0_wp) !! i1mach(14) real(wp),parameter :: d1mach5 = log10(real(radix(x),wp)) !! d1mach(5) real(wp),parameter :: ln2 = log(2.0_wp) !! 0.69314718d0 real(wp),parameter :: sq2 = sqrt(2.0_wp) integer(ip),parameter :: nlmn = 1 integer(ip),parameter :: kmx = 5000 integer(ip),parameter :: kml = 6 ! initialize inbv = 1_ip iflag = 0_ip k = i1mach14 anib = d1mach5*k/0.30102000_wp nbits = int(anib,ip) nlmx = min((nbits*5_ip)/8_ip,60_ip) ans = 0.0_wp ce = 0.0_wp if ( a==b ) then if ( err<0.0_wp ) err = ce return else lmx = nlmx lmn = nlmn if ( b/=0.0_wp ) then if ( sign(1.0_wp,b)*a>0.0_wp ) then c = abs(1.0_wp-a/b) if ( c<=0.1_wp ) then if ( c<=0.0_wp ) then if ( err<0.0_wp ) err = ce return else anib = 0.5_wp - log(c)/ln2 nib = int(anib,ip) lmx = min(nlmx,nbits-nib-7_ip) if ( lmx<1_ip ) then ! a and b are too nearly equal ! to allow normal integration iflag = 1101_ip if ( err<0.0_wp ) err = ce return else lmn = min(lmn,lmx) end if end if end if end if end if tol = max(abs(err),2.0_wp**(5-nbits))/2.0_wp if ( err==0.0_wp ) tol = sqrt(epsilon(1.0_wp)) eps = tol hh(1_ip) = (b-a)/4.0_wp aa(1_ip) = a lr(1_ip) = 1_ip l = 1_ip call g8(aa(l)+2.0_wp*hh(l),2.0_wp*hh(l),est,iflag) if (iflag/=0_ip) return k = 8_ip area = abs(est) ef = 0.5_wp mxl = 0_ip end if do ! compute refined estimates, estimate the error, etc. call g8(aa(l)+hh(l),hh(l),gl,iflag) if (iflag/=0_ip) return call g8(aa(l)+3.0_wp*hh(l),hh(l),gr(l),iflag) if (iflag/=0_ip) return k = k + 16_ip area = area + (abs(gl)+abs(gr(l))-abs(est)) glr = gl + gr(l) ee = abs(est-glr)*ef ae = max(eps*area,tol*abs(glr)) if ( ee>ae ) then ! consider the left half of this level if ( k>kmx ) lmx = kml if ( l>=lmx ) then mxl = 1_ip else l = l + 1_ip eps = eps*0.5_wp ef = ef/sq2 hh(l) = hh(l-1)*0.5_wp lr(l) = -1_ip aa(l) = aa(l-1_ip) est = gl cycle end if end if ce = ce + (est-glr) if ( lr(l)<=0_ip ) then ! proceed to right half at this level vl(l) = glr else ! return one level vr = glr do if ( l<=1_ip ) then ! exit ans = vr if ( (mxl/=0_ip) .and. (abs(ce)>2.0_wp*tol*area) ) then iflag = 1102_ip end if if ( err<0.0_wp ) err = ce return else l = l - 1_ip eps = eps*2.0_wp ef = ef*sq2 if ( lr(l)<=0 ) then vl(l) = vl(l+1_ip) + vr exit else vr = vl(l+1_ip) + vr end if end if end do end if est = gr(l-1_ip) lr(l) = 1_ip aa(l) = aa(l) + 4.0_wp*hh(l) end do contains subroutine g8(x,h,res,iflag) !! 8-point formula. !! !!@note The abscissa and weight coefficients (`gl8_x1`, ..., `gl8_w4`) !! are the higher precision versions (about 300 digits) from here: !! http://pomax.github.io/bezierinfo/legendre-gauss.html !! So, if `wp` is changed to say, `real128`, more precision !! can be obtained. implicit none real(wp),intent(in) :: x real(wp),intent(in) :: h real(wp),intent(out) :: res integer(ip),intent(out) :: iflag real(wp),dimension(8) :: f real(wp),dimension(8) :: v res = 0.0_wp v(1_ip) = x-gl8_x1*h v(2_ip) = x+gl8_x1*h v(3_ip) = x-gl8_x2*h v(4_ip) = x+gl8_x2*h v(5_ip) = x-gl8_x3*h v(6_ip) = x+gl8_x3*h v(7_ip) = x-gl8_x4*h v(8_ip) = x+gl8_x4*h call dbvalu(xt,bc,n,kk,id,v(1_ip),inbv,work,iflag,f(1_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(2_ip),inbv,work,iflag,f(2_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(3_ip),inbv,work,iflag,f(3_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(4_ip),inbv,work,iflag,f(4_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(5_ip),inbv,work,iflag,f(5_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(6_ip),inbv,work,iflag,f(6_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(7_ip),inbv,work,iflag,f(7_ip)); if (iflag/=0_ip) return call dbvalu(xt,bc,n,kk,id,v(8_ip),inbv,work,iflag,f(8_ip)); if (iflag/=0_ip) return res = h*((gl8_w1*(fun(v(1_ip))*f(1_ip) + fun(v(2_ip))*f(2_ip)) + & gl8_w2*(fun(v(3_ip))*f(3_ip) + fun(v(4_ip))*f(4_ip))) + & (gl8_w3*(fun(v(5_ip))*f(5_ip) + fun(v(6_ip))*f(6_ip)) + & gl8_w4*(fun(v(7_ip))*f(7_ip) + fun(v(8_ip))*f(8_ip)))) end subroutine g8 end subroutine dbsgq8 !***************************************************************************************** !***************************************************************************************** !> ! Returns the value of `x` to use for computing the interval ! in `t`, depending on if extrapolation is allowed or not. ! ! If extrapolation is allowed and x is < tmin or > tmax, then either ! `tmin` or `tmax - 2.0_wp*spacing(tmax)` is returned. ! Otherwise, `x` is returned. pure function get_temp_x_for_extrap(x,tmin,tmax,extrap) result(xt) implicit none real(wp),intent(in) :: x !! variable value real(wp),intent(in) :: tmin !! first knot vector element for b-splines real(wp),intent(in) :: tmax !! last knot vector element for b-splines real(wp) :: xt !! The value returned (it will either !! be `tmin`, `x`, or `tmax`) logical,intent(in),optional :: extrap !! if extrapolation is allowed !! (if not present, default is False) logical :: extrapolation_allowed !! if extrapolation is allowed if (present(extrap)) then extrapolation_allowed = extrap else extrapolation_allowed = .false. end if if (extrapolation_allowed) then if (x<tmin) then xt = tmin else if (x>tmax) then ! Put it just inside the upper bound. ! This is sort of a hack to get ! extrapolation to work. xt = tmax - 2.0_wp*spacing(tmax) else xt = x end if else xt = x end if end function get_temp_x_for_extrap !***************************************************************************************** !***************************************************************************************** !> ! Returns a message string associated with the status code. pure function get_status_message(iflag) result(msg) implicit none integer(ip),intent(in) :: iflag !! return code from one of the routines character(len=:),allocatable :: msg !! status message associated with the flag character(len=10) :: istr !! for integer to string conversion integer(ip) :: istat !! for write statement select case (iflag) case( 0_ip); msg='Successful execution' case( -1_ip); msg='Error in dintrv: x < xt(1_ip)' case( -2_ip); msg='Error in dintrv: x >= xt(lxt)' case( 1_ip); msg='Error in evaluate_*d: class is not initialized' case( 2_ip); msg='Error in db*ink: iknot out of range' case( 3_ip); msg='Error in db*ink: nx out of range' case( 4_ip); msg='Error in db*ink: kx out of range' case( 5_ip); msg='Error in db*ink: x not strictly increasing' case( 6_ip); msg='Error in db*ink: tx not non-decreasing' case( 7_ip); msg='Error in db*ink: ny out of range' case( 8_ip); msg='Error in db*ink: ky out of range' case( 9_ip); msg='Error in db*ink: y not strictly increasing' case( 10_ip); msg='Error in db*ink: ty not non-decreasing' case( 11_ip); msg='Error in db*ink: nz out of range' case( 12_ip); msg='Error in db*ink: kz out of range' case( 13_ip); msg='Error in db*ink: z not strictly increasing' case( 14_ip); msg='Error in db*ink: tz not non-decreasing' case( 15_ip); msg='Error in db*ink: nq out of range' case( 16_ip); msg='Error in db*ink: kq out of range' case( 17_ip); msg='Error in db*ink: q not strictly increasing' case( 18_ip); msg='Error in db*ink: tq not non-decreasing' case( 19_ip); msg='Error in db*ink: nr out of range' case( 20_ip); msg='Error in db*ink: kr out of range' case( 21_ip); msg='Error in db*ink: r not strictly increasing' case( 22_ip); msg='Error in db*ink: tr not non-decreasing' case( 23_ip); msg='Error in db*ink: ns out of range' case( 24_ip); msg='Error in db*ink: ks out of range' case( 25_ip); msg='Error in db*ink: s not strictly increasing' case( 26_ip); msg='Error in db*ink: ts not non-decreasing' case(700_ip); msg='Error in db*ink: size(x) /= size(fcn,1)' case(701_ip); msg='Error in db*ink: size(y) /= size(fcn,2)' case(702_ip); msg='Error in db*ink: size(z) /= size(fcn,3)' case(703_ip); msg='Error in db*ink: size(q) /= size(fcn,4)' case(704_ip); msg='Error in db*ink: size(r) /= size(fcn,5)' case(705_ip); msg='Error in db*ink: size(s) /= size(fcn,6)' case(706_ip); msg='Error in db*ink: size(x) /= nx' case(707_ip); msg='Error in db*ink: size(y) /= ny' case(708_ip); msg='Error in db*ink: size(z) /= nz' case(709_ip); msg='Error in db*ink: size(q) /= nq' case(710_ip); msg='Error in db*ink: size(r) /= nr' case(711_ip); msg='Error in db*ink: size(s) /= ns' case(712_ip); msg='Error in db*ink: size(tx) /= nx+kx' case(713_ip); msg='Error in db*ink: size(ty) /= ny+ky' case(714_ip); msg='Error in db*ink: size(tz) /= nz+kz' case(715_ip); msg='Error in db*ink: size(tq) /= nq+kq' case(716_ip); msg='Error in db*ink: size(tr) /= nr+kr' case(717_ip); msg='Error in db*ink: size(ts) /= ns+ks' case(800_ip); msg='Error in db*ink: size(x) /= size(bcoef,1)' case(801_ip); msg='Error in db*ink: size(y) /= size(bcoef,2)' case(802_ip); msg='Error in db*ink: size(z) /= size(bcoef,3)' case(803_ip); msg='Error in db*ink: size(q) /= size(bcoef,4)' case(804_ip); msg='Error in db*ink: size(r) /= size(bcoef,5)' case(805_ip); msg='Error in db*ink: size(s) /= size(bcoef,6)' case(806_ip); msg='Error in dbint4: k must be >= 3' case(100_ip); msg='Error in dbintk: k does not satisfy k>=1' case(101_ip); msg='Error in dbintk: n does not satisfy n>=k' case(102_ip); msg='Error in dbintk: x(i) does not satisfy x(i)<x(i+1) for some i' case(103_ip); msg='Error in dbintk: some abscissa was not in the support of the '//& 'corresponding basis function and the system is singular' case(104_ip); msg='Error in dbintk: the system of solver detects a singular system '//& 'although the theoretical conditions for a solution were satisfied' case(201_ip); msg='Error in dbspvn: k does not satisfy k>=1' case(202_ip); msg='Error in dbspvn: jhigh does not satisfy 1<=jhigh<=k' case(203_ip); msg='Error in dbspvn: index is not 1 or 2' case(204_ip); msg='Error in dbspvn: x does not satisfy t(ileft)<=x<=t(ileft+1)' case(301_ip); msg='Error in dbtpcf: n should be > 0' case(401_ip); msg='Error in dbvalu: k does not satisfy k>=1' case(402_ip); msg='Error in dbvalu: n does not satisfy n>=k' case(403_ip); msg='Error in dbvalu: ideriv does not satisfy 0<=ideriv<k' case(404_ip); msg='Error in dbvalu: x is not greater than or equal to t(k)' case(405_ip); msg='Error in dbvalu: x is not less than or equal to t(n+1)' case(406_ip); msg='Error in dbvalu: a left limiting value cannot be obtained at t(k)' case(501_ip); msg='Error in initialize_*d_specify_knots: tx is not the correct size (kx+nx)' case(502_ip); msg='Error in initialize_*d_specify_knots: ty is not the correct size (ky+ny)' case(503_ip); msg='Error in initialize_*d_specify_knots: tz is not the correct size (kz+nz)' case(504_ip); msg='Error in initialize_*d_specify_knots: tq is not the correct size (kq+nq)' case(505_ip); msg='Error in initialize_*d_specify_knots: tr is not the correct size (kr+nr)' case(506_ip); msg='Error in initialize_*d_specify_knots: ts is not the correct size (ks+ns)' case(601_ip); msg='Error in db*val: x value out of bounds' case(602_ip); msg='Error in db*val: y value out of bounds' case(603_ip); msg='Error in db*val: z value out of bounds' case(604_ip); msg='Error in db*val: q value out of bounds' case(605_ip); msg='Error in db*val: r value out of bounds' case(606_ip); msg='Error in db*val: s value out of bounds' case(901_ip); msg='Error in dbsqad: k does not satisfy 1<=k<=20' case(902_ip); msg='Error in dbsqad: n does not satisfy n>=k' case(903_ip); msg='Error in dbsqad: x1 or x2 or both do not satisfy t(k)<=x<=t(n+1)' case(1001_ip); msg='Error in dbfqad: k does not satisfy k>=1' case(1002_ip); msg='Error in dbfqad: n does not satisfy n>=k' case(1003_ip); msg='Error in dbfqad: d does not satisfy 0<=id<k' case(1004_ip); msg='Error in dbfqad: x1 or x2 or both do not satisfy t(k)<=x<=t(n+1)' case(1005_ip); msg='Error in dbfqad: tol is less than dtol or greater than 0.1' case(1101_ip); msg='Warning in dbsgq8: a and b are too nearly equal to allow normal integration.' case(1102_ip); msg='Error in dbsgq8: ans is probably insufficiently accurate.' case(2001_ip); msg='Error in dbint4: ndata is less than max(2,k-2)' case(2002_ip); msg='Error in dbint4: x values are not distinct or not ordered' case(2003_ip); msg='Error in dbint4: ibcl is not in the range 1 to k-1' case(2004_ip); msg='Error in dbint4: ibcr is not in the range 1 to k-1' case(2005_ip); msg='Error in dbint4: kntopt is not 1, 2, or 3' case(2006_ip); msg='Error in dbint4: knot input through tleft, tright is not ordered properly' case(2007_ip); msg='Error in dbint4: the system of equations is singular' case(2008_ip); msg='Error in dbint4: tleft or tright does not have size k-1' case(4001_ip); msg='Error in db1root/db1min/db1max: k does not satisfy k>=2' case(4002_ip); msg='Error in db1root/db1min/db1max: n does not satisfy n>=k' case(4003_ip); msg='Error in db1min/db1max: xa or xb or both do not satisfy t(k)<=x<=t(n+1)' case(4004_ip); msg='Warning in db1root: the spline is equal to a over a whole knot interval' case(4005_ip); msg='Error in inverse: there is no x with s(x)=y' case(4006_ip); msg='Error in inverse: there is more than one x with s(x)=y' case(4007_ip); msg='Warning in db1min/db1max: the extremum is the limit from the left at a discontinuity' case(5001_ip); msg='Error in initialize_from_coefficients: k does not satisfy k>=1' case(5002_ip); msg='Error in initialize_from_coefficients: n does not satisfy n>=k' case(5003_ip); msg='Error in initialize_from_coefficients: a knot vector is not the correct size (n+k)' case(5004_ip); msg='Error in initialize_from_coefficients: a knot vector is not non-decreasing' case(5005_ip); msg='Error in initialize_from_coefficients: a knot vector does not satisfy t(k)<t(n+1)' case(6001_ip); msg='Error in db*ink (multiple outputs): fcn and bcoef do not have the same number of outputs' case(6002_ip); msg='Error in db*val (multiple outputs): size(f) is not the number of outputs' case(6003_ip); msg='Error: this method requires a spline with a single output' case(6004_ip); msg='Error in db*val (multiple outputs): the leading dimensions of bcoef do not match nx, ny, ...' case(6005_ip); msg='Error in initialize_from_coefficients (multiple outputs): bcoef has no outputs (its last dimension is zero)' case(3001_ip); msg='Error in dbspvd: k does not satisfy k>=1' case(3002_ip); msg='Error in dbspvd: nderiv does not satisfy 1<=nderiv<=k' case(3003_ip); msg='Error in dbspvd: ldvnik does not satisfy ldvnik>=k' case default write(istr,fmt='(I10)',iostat=istat) iflag if (istat/=0_ip) then msg = 'Unknown status flag' else msg = 'Unknown status flag: '//trim(adjustl(istr)) end if end select end function get_status_message !***************************************************************************************** !***************************************************************************************** end module bspline_sub_module !*****************************************************************************************