check_inputs – bspline-fortran

private 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)

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.

Arguments

Type	Intent	Optional	Attributes		Name
integer(kind=ip),	intent(in)			::	iknot	= 0 if the `INK` routine is computing the knots.
integer(kind=ip),	intent(out)			::	iflag
integer(kind=ip),	intent(in),	optional		::	nx
integer(kind=ip),	intent(in),	optional		::	ny
integer(kind=ip),	intent(in),	optional		::	nz
integer(kind=ip),	intent(in),	optional		::	nq
integer(kind=ip),	intent(in),	optional		::	nr
integer(kind=ip),	intent(in),	optional		::	ns
integer(kind=ip),	intent(in),	optional		::	kx
integer(kind=ip),	intent(in),	optional		::	ky
integer(kind=ip),	intent(in),	optional		::	kz
integer(kind=ip),	intent(in),	optional		::	kq
integer(kind=ip),	intent(in),	optional		::	kr
integer(kind=ip),	intent(in),	optional		::	ks
real(kind=wp),	intent(in),	optional,	dimension(:)	::	x
real(kind=wp),	intent(in),	optional,	dimension(:)	::	y
real(kind=wp),	intent(in),	optional,	dimension(:)	::	z
real(kind=wp),	intent(in),	optional,	dimension(:)	::	q
real(kind=wp),	intent(in),	optional,	dimension(:)	::	r
real(kind=wp),	intent(in),	optional,	dimension(:)	::	s
real(kind=wp),	intent(in),	optional,	dimension(:)	::	tx
real(kind=wp),	intent(in),	optional,	dimension(:)	::	ty
real(kind=wp),	intent(in),	optional,	dimension(:)	::	tz
real(kind=wp),	intent(in),	optional,	dimension(:)	::	tq
real(kind=wp),	intent(in),	optional,	dimension(:)	::	tr
real(kind=wp),	intent(in),	optional,	dimension(:)	::	ts
real(kind=wp),	intent(in),	optional,	dimension(:)	::	f1
real(kind=wp),	intent(in),	optional,	dimension(:,:)	::	f2
real(kind=wp),	intent(in),	optional,	dimension(:,:,:)	::	f3
real(kind=wp),	intent(in),	optional,	dimension(:,:,:,:)	::	f4
real(kind=wp),	intent(in),	optional,	dimension(:,:,:,:,:)	::	f5
real(kind=wp),	intent(in),	optional,	dimension(:,:,:,:,:,:)	::	f6
real(kind=wp),	intent(in),	optional,	dimension(:)	::	bcoef1
real(kind=wp),	intent(in),	optional,	dimension(:,:)	::	bcoef2
real(kind=wp),	intent(in),	optional,	dimension(:,:,:)	::	bcoef3
real(kind=wp),	intent(in),	optional,	dimension(:,:,:,:)	::	bcoef4
real(kind=wp),	intent(in),	optional,	dimension(:,:,:,:,:)	::	bcoef5
real(kind=wp),	intent(in),	optional,	dimension(:,:,:,:,:,:)	::	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

Source Code

    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 & `k=4`]

    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
            call check_k('k'//s,k+ik,n,ierrs(2),iflag,error); 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<3 check, size(x)==n check]
        integer(ip),intent(out)             :: iflag !! status return code
        logical,intent(out)                 :: error

        if (n < 3_ip) 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,n,ierr,iflag,error)

        implicit none

        character(len=*),intent(in) :: s
        integer(ip),intent(in)      :: k
        integer(ip),intent(in)      :: n
        integer(ip),intent(in)      :: ierr
        integer(ip),intent(out)     :: iflag !! status return code
        logical,intent(out)         :: error

        if ((k < 2_ip) .or. (k >= n)) 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

check_inputs Subroutine

Contents

Source Code

private 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)

Notes

History

Arguments

Called by

Source Code