[Scipy-svn] r4610 - in branches/Interpolate1D: . extensions extensions/fitpack extensions/fitpack/fitpack
scipy-svn at scipy.org
scipy-svn at scipy.org
Thu Aug 7 17:25:34 EDT 2008
Author: fcady
Date: 2008-08-07 16:25:16 -0500 (Thu, 07 Aug 2008)
New Revision: 4610
Added:
branches/Interpolate1D/extensions/
branches/Interpolate1D/extensions/_fitpack.pyf
branches/Interpolate1D/extensions/_interpolate.cpp
branches/Interpolate1D/extensions/fitpack/
branches/Interpolate1D/extensions/fitpack/fitpack/
branches/Interpolate1D/extensions/interpolate.h
branches/Interpolate1D/extensions/multipack.h
branches/Interpolate1D/extensions/ndimage/
Removed:
branches/Interpolate1D/_fitpack.pyf
branches/Interpolate1D/_interpolate.cpp
branches/Interpolate1D/extensions/fitpack/fitpack/Makefile
branches/Interpolate1D/extensions/fitpack/fitpack/README
branches/Interpolate1D/extensions/fitpack/fitpack/bispev.f
branches/Interpolate1D/extensions/fitpack/fitpack/clocur.f
branches/Interpolate1D/extensions/fitpack/fitpack/cocosp.f
branches/Interpolate1D/extensions/fitpack/fitpack/concon.f
branches/Interpolate1D/extensions/fitpack/fitpack/concur.f
branches/Interpolate1D/extensions/fitpack/fitpack/cualde.f
branches/Interpolate1D/extensions/fitpack/fitpack/curev.f
branches/Interpolate1D/extensions/fitpack/fitpack/curfit.f
branches/Interpolate1D/extensions/fitpack/fitpack/dblint.f
branches/Interpolate1D/extensions/fitpack/fitpack/evapol.f
branches/Interpolate1D/extensions/fitpack/fitpack/fourco.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpader.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpadno.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpadpo.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpback.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpbacp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpbfout.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpbisp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpbspl.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpchec.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpched.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpchep.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpclos.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcoco.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcons.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcosp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcsin.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcurf.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcuro.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcyt1.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpcyt2.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpdeno.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpdisc.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpfrno.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpgivs.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpgrdi.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpgrpa.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpgrre.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpgrsp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpinst.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpintb.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpknot.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpopdi.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpopsp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fporde.f
branches/Interpolate1D/extensions/fitpack/fitpack/fppara.f
branches/Interpolate1D/extensions/fitpack/fitpack/fppasu.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpperi.f
branches/Interpolate1D/extensions/fitpack/fitpack/fppocu.f
branches/Interpolate1D/extensions/fitpack/fitpack/fppogr.f
branches/Interpolate1D/extensions/fitpack/fitpack/fppola.f
branches/Interpolate1D/extensions/fitpack/fitpack/fprank.f
branches/Interpolate1D/extensions/fitpack/fitpack/fprati.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpregr.f
branches/Interpolate1D/extensions/fitpack/fitpack/fprota.f
branches/Interpolate1D/extensions/fitpack/fitpack/fprppo.f
branches/Interpolate1D/extensions/fitpack/fitpack/fprpsp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpseno.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpspgr.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpsphe.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpsuev.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpsurf.f
branches/Interpolate1D/extensions/fitpack/fitpack/fpsysy.f
branches/Interpolate1D/extensions/fitpack/fitpack/fptrnp.f
branches/Interpolate1D/extensions/fitpack/fitpack/fptrpe.f
branches/Interpolate1D/extensions/fitpack/fitpack/insert.f
branches/Interpolate1D/extensions/fitpack/fitpack/parcur.f
branches/Interpolate1D/extensions/fitpack/fitpack/parder.f
branches/Interpolate1D/extensions/fitpack/fitpack/parsur.f
branches/Interpolate1D/extensions/fitpack/fitpack/percur.f
branches/Interpolate1D/extensions/fitpack/fitpack/pogrid.f
branches/Interpolate1D/extensions/fitpack/fitpack/polar.f
branches/Interpolate1D/extensions/fitpack/fitpack/profil.f
branches/Interpolate1D/extensions/fitpack/fitpack/regrid.f
branches/Interpolate1D/extensions/fitpack/fitpack/spalde.f
branches/Interpolate1D/extensions/fitpack/fitpack/spgrid.f
branches/Interpolate1D/extensions/fitpack/fitpack/sphere.f
branches/Interpolate1D/extensions/fitpack/fitpack/splder.f
branches/Interpolate1D/extensions/fitpack/fitpack/splev.f
branches/Interpolate1D/extensions/fitpack/fitpack/splint.f
branches/Interpolate1D/extensions/fitpack/fitpack/sproot.f
branches/Interpolate1D/extensions/fitpack/fitpack/surev.f
branches/Interpolate1D/extensions/fitpack/fitpack/surfit.f
branches/Interpolate1D/fitpack/
branches/Interpolate1D/interpolate.h
branches/Interpolate1D/multipack.h
branches/Interpolate1D/ndimage/
Modified:
branches/Interpolate1D/setup.py
Log:
for cleanness of file, put all under-the-hood extensions into a single directory
Deleted: branches/Interpolate1D/_fitpack.pyf
===================================================================
--- branches/Interpolate1D/_fitpack.pyf 2008-08-07 21:05:37 UTC (rev 4609)
+++ branches/Interpolate1D/_fitpack.pyf 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,479 +0,0 @@
-! -*- f90 -*-
-! Author: Pearu Peterson <pearu at cens.ioc.ee>
-!
-python module _dfitpack ! in
-
- usercode '''
-
-static double dmax(double* seq,int len) {
- double val;
- int i;
- if (len<1)
- return -1e308;
- val = seq[0];
- for(i=1;i<len;++i)
- if (seq[i]>val) val = seq[i];
- return val;
-}
-static double dmin(double* seq,int len) {
- double val;
- int i;
- if (len<1)
- return 1e308;
- val = seq[0];
- for(i=1;i<len;++i)
- if (seq[i]<val) val = seq[i];
- return val;
-}
-static double calc_b(double* x,int m,double* tx,int nx) {
- double val1 = dmin(x,m);
- double val2 = dmin(tx,nx);
- if (val2>val1) return val1;
- val1 = dmax(tx,nx);
- return val2 - (val1-val2)/nx;
-}
-static double calc_e(double* x,int m,double* tx,int nx) {
- double val1 = dmax(x,m);
- double val2 = dmax(tx,nx);
- if (val2<val1) return val1;
- val1 = dmin(tx,nx);
- return val2 + (val2-val1)/nx;
-}
-static int imax(int i1,int i2) {
- return MAX(i1,i2);
-}
-
-static int calc_surfit_lwrk1(int m, int kx, int ky, int nxest, int nyest) {
- int u = nxest-kx-1;
- int v = nyest-ky-1;
- int km = MAX(kx,ky)+1;
- int ne = MAX(nxest,nyest);
- int bx = kx*v+ky+1;
- int by = ky*u+kx+1;
- int b1,b2;
- if (bx<=by) {b1=bx;b2=bx+v-ky;}
- else {b1=by;b2=by+u-kx;}
- return u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1;
-}
-static int calc_surfit_lwrk2(int m, int kx, int ky, int nxest, int nyest) {
- int u = nxest-kx-1;
- int v = nyest-ky-1;
- int bx = kx*v+ky+1;
- int by = ky*u+kx+1;
- int b2 = (bx<=by?bx+v-ky:by+u-kx);
- return u*v*(b2+1)+b2;
-}
-
-static int calc_regrid_lwrk(int mx, int my, int kx, int ky,
- int nxest, int nyest) {
- int u = MAX(my, nxest);
- return 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+my*(ky+1)+u;
-}
-'''
-
- interface
-
- !!!!!!!!!! Univariate spline !!!!!!!!!!!
-
- subroutine splev(t,n,c,k,x,y,m,ier)
- ! y = splev(t,c,k,x)
- real*8 dimension(n),intent(in) :: t
- integer intent(hide),depend(t) :: n=len(t)
- real*8 dimension(n),depend(n,k),check(len(c)==n),intent(in) :: c
- integer :: k
- real*8 dimension(m),intent(in) :: x
- real*8 dimension(m),depend(m),intent(out) :: y
- integer intent(hide),depend(x) :: m=len(x)
- integer intent(hide) :: ier
- end subroutine splev
-
- subroutine splder(t,n,c,k,nu,x,y,m,wrk,ier)
- ! dy = splder(t,c,k,x,[nu])
- real*8 dimension(n) :: t
- integer depend(t),intent(hide) :: n=len(t)
- real*8 dimension(n),depend(n,k),check(len(c)==n),intent(in) :: c
- integer :: k
- integer depend(k),check(0<=nu && nu<=k) :: nu = 1
- real*8 dimension(m) :: x
- real*8 dimension(m),depend(m),intent(out) :: y
- integer depend(x),intent(hide) :: m=len(x)
- real*8 dimension(n),depend(n),intent(cache,hide) :: wrk
- integer intent(hide) :: ier
- end subroutine splder
-
- function splint(t,n,c,k,a,b,wrk)
- ! iy = splint(t,c,k,a,b)
- real*8 dimension(n),intent(in) :: t
- integer intent(hide),depend(t) :: n=len(t)
- real*8 dimension(n),depend(n),check(len(c)==n) :: c
- integer intent(in) :: k
- real*8 intent(in) :: a
- real*8 intent(in) :: b
- real*8 dimension(n),depend(n),intent(cache,hide) :: wrk
- real*8 :: splint
- end function splint
-
- subroutine sproot(t,n,c,zero,mest,m,ier)
- ! zero,m,ier = sproot(t,c[,mest])
- real*8 dimension(n),intent(in) :: t
- integer intent(hide),depend(t),check(n>=8) :: n=len(t)
- real*8 dimension(n),depend(n),check(len(c)==n) :: c
- real*8 dimension(mest),intent(out),depend(mest) :: zero
- integer optional,intent(in),depend(n) :: mest=3*(n-7)
- integer intent(out) :: m
- integer intent(out) :: ier
- end subroutine sproot
-
- subroutine spalde(t,n,c,k,x,d,ier)
- ! d,ier = spalde(t,c,k,x)
-
- callprotoargument double*,int*,double*,int*,double*,double*,int*
- callstatement {int k1=k+1; (*f2py_func)(t,&n,c,&k1,&x,d,&ier); }
-
- real*8 dimension(n) :: t
- integer intent(hide),depend(t) :: n=len(t)
- real*8 dimension(n),depend(n),check(len(c)==n) :: c
- integer intent(in) :: k
- real*8 intent(in) :: x
- real*8 dimension(k+1),intent(out),depend(k) :: d
- integer intent(out) :: ier
- end subroutine spalde
-
- subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk,lwrk,iwrk,ier)
- ! in curfit.f
- integer :: iopt
- integer intent(hide),depend(x),check(m>k),depend(k) :: m=len(x)
- real*8 dimension(m) :: x
- real*8 dimension(m),depend(m),check(len(y)==m) :: y
- real*8 dimension(m),depend(m),check(len(w)==m) :: w
- real*8 optional,depend(x),check(xb<=x[0]) :: xb = x[0]
- real*8 optional,depend(x,m),check(xe>=x[m-1]) :: xe = x[m-1]
- integer optional,check(1<=k && k <=5),intent(in) :: k=3
- real*8 optional,check(s>=0.0) :: s = 0.0
- integer intent(hide),depend(t) :: nest=len(t)
- integer intent(out), depend(nest) :: n=nest
- real*8 dimension(nest),intent(inout) :: t
- real*8 dimension(n),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(lwrk),intent(inout) :: wrk
- integer intent(hide),depend(wrk) :: lwrk=len(wrk)
- integer dimension(nest),intent(inout) :: iwrk
- integer intent(out) :: ier
- end subroutine curfit
-
- subroutine percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp,wrk,lwrk,iwrk,ier)
- ! in percur.f
- integer :: iopt
- integer intent(hide),depend(x),check(m>k),depend(k) :: m=len(x)
- real*8 dimension(m) :: x
- real*8 dimension(m),depend(m),check(len(y)==m) :: y
- real*8 dimension(m),depend(m),check(len(w)==m) :: w
- integer optional,check(1<=k && k <=5),intent(in) :: k=3
- real*8 optional,check(s>=0.0) :: s = 0.0
- integer intent(hide),depend(t) :: nest=len(t)
- integer intent(out), depend(nest) :: n=nest
- real*8 dimension(nest),intent(inout) :: t
- real*8 dimension(n),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(lwrk),intent(inout) :: wrk
- integer intent(hide),depend(wrk) :: lwrk=len(wrk)
- integer dimension(nest),intent(inout) :: iwrk
- integer intent(out) :: ier
- end subroutine percur
-
-
- subroutine parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t,nc,c,fp,wrk,lwrk,iwrk,ier)
- ! in parcur.f
- integer check(iopt>=-1 && iopt <= 1):: iopt
- integer check(ipar == 1 || ipar == 0) :: ipar
- integer check(idim > 0 && idim < 11) :: idim
- integer intent(hide),depend(u,k),check(m>k) :: m=len(u)
- real*8 dimension(m), intent(inout) :: u
- integer intent(hide),depend(x,idim,m),check(mx>=idim*m) :: mx=len(x)
- real*8 dimension(mx) :: x
- real*8 dimension(m) :: w
- real*8 :: ub
- real*8 :: ue
- integer optional, check(1<=k && k<=5) :: k=3.0
- real*8 optional, check(s>=0.0) :: s = 0.0
- integer intent(hide), depend(t) :: nest=len(t)
- integer intent(out), depend(nest) :: n=nest
- real*8 dimension(nest), intent(inout) :: t
- integer intent(hide), depend(c,nest,idim), check(nc>=idim*nest) :: nc=len(c)
- real*8 dimension(nc), intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(lwrk), intent(inout) :: wrk
- integer intent(hide),depend(wrk) :: lwrk=len(wrk)
- integer dimension(nest), intent(inout) :: iwrk
- integer intent(out) :: ier
- end subroutine parcur
-
-
- subroutine fpcurf0(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp,fpint,wrk,nrdata,ier)
- ! x,y,w,xb,xe,k,s,n,t,c,fp,fpint,nrdata,ier = \
- ! fpcurf0(x,y,k,[w,xb,xe,s,nest])
-
- fortranname fpcurf
- callprotoargument int*,double*,double*,double*,int*,double*,double*,int*,double*,int*,double*,int*,int*,int*,int*,double*,double*,double*,double*,double*,double*,double*,double*,double*,int*,int*
- callstatement (*f2py_func)(&iopt,x,y,w,&m,&xb,&xe,&k,&s,&nest,&tol,&maxit,&k1,&k2,&n,t,c,&fp,fpint,wrk,wrk+nest,wrk+nest*k2,wrk+nest*2*k2,wrk+nest*3*k2,nrdata,&ier)
-
- integer intent(hide) :: iopt = 0
- real*8 dimension(m),intent(in,out) :: x
- real*8 dimension(m),depend(m),check(len(y)==m),intent(in,out) :: y
- real*8 dimension(m),depend(m),check(len(w)==m),intent(in,out) :: w = 1.0
- integer intent(hide),depend(x),check(m>k),depend(k) :: m=len(x)
- real*8 intent(in,out),depend(x),check(xb<=x[0]) :: xb = x[0]
- real*8 intent(in,out),depend(x,m),check(xe>=x[m-1]) :: xe = x[m-1]
- integer check(1<=k && k<=5),intent(in,out) :: k
- real*8 check(s>=0.0),depend(m),intent(in,out) :: s = m
- integer intent(in),depend(m,s,k,k1),check(nest>=2*k1) :: nest = (s==0.0?m+k+1:MAX(m/2,2*k1))
- real*8 intent(hide) :: tol = 0.001
- integer intent(hide) :: maxit = 20
- integer intent(hide),depend(k) :: k1=k+1
- integer intent(hide),depend(k) :: k2=k+2
- integer intent(out) :: n
- real*8 dimension(nest),intent(out),depend(nest) :: t
- real*8 dimension(nest),depend(nest),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(nest),depend(nest),intent(out,cache) :: fpint
- real*8 dimension(nest*3*k2+m*k1),intent(cache,hide),depend(nest,k1,k2,m) :: wrk
- integer dimension(nest),depend(nest),intent(out,cache) :: nrdata
- integer intent(out) :: ier
- end subroutine fpcurf0
-
- subroutine fpcurf1(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp,fpint,wrk,nrdata,ier)
- ! x,y,w,xb,xe,k,s,n,t,c,fp,fpint,nrdata,ier = \
- ! fpcurf1(x,y,w,xb,xe,k,s,n,t,c,fp,fpint,nrdata,ier)
-
- fortranname fpcurf
- callprotoargument int*,double*,double*,double*,int*,double*,double*,int*,double*,int*,double*,int*,int*,int*,int*,double*,double*,double*,double*,double*,double*,double*,double*,double*,int*,int*
- callstatement (*f2py_func)(&iopt,x,y,w,&m,&xb,&xe,&k,&s,&nest,&tol,&maxit,&k1,&k2,&n,t,c,&fp,fpint,wrk,wrk+nest,wrk+nest*k2,wrk+nest*2*k2,wrk+nest*3*k2,nrdata,&ier)
-
- integer intent(hide) :: iopt = 1
- real*8 dimension(m),intent(in,out,overwrite) :: x
- real*8 dimension(m),depend(m),check(len(y)==m),intent(in,out,overwrite) :: y
- real*8 dimension(m),depend(m),check(len(w)==m),intent(in,out,overwrite) :: w
- integer intent(hide),depend(x),check(m>k),depend(k) :: m=len(x)
- real*8 intent(in,out) :: xb
- real*8 intent(in,out) :: xe
- integer check(1<=k && k<=5),intent(in,out) :: k
- real*8 check(s>=0.0),intent(in,out) :: s
- integer intent(hide),depend(t) :: nest = len(t)
- real*8 intent(hide) :: tol = 0.001
- integer intent(hide) :: maxit = 20
- integer intent(hide),depend(k) :: k1=k+1
- integer intent(hide),depend(k) :: k2=k+2
- integer intent(in,out) :: n
- real*8 dimension(nest),intent(in,out,overwrite) :: t
- real*8 dimension(nest),depend(nest),check(len(c)==nest),intent(in,out,overwrite) :: c
- real*8 intent(in,out) :: fp
- real*8 dimension(nest),depend(nest),check(len(fpint)==nest),intent(in,out,cache,overwrite) :: fpint
- real*8 dimension(nest*3*k2+m*k1),intent(cache,hide),depend(nest,k1,k2,m) :: wrk
- integer dimension(nest),depend(nest),check(len(nrdata)==nest),intent(in,out,cache,overwrite) :: nrdata
- integer intent(in,out) :: ier
- end subroutine fpcurf1
-
- subroutine fpcurfm1(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp,fpint,wrk,nrdata,ier)
- ! x,y,w,xb,xe,k,s,n,t,c,fp,fpint,nrdata,ier = \
- ! fpcurfm1(x,y,k,t,[w,xb,xe])
-
- fortranname fpcurf
- callprotoargument int*,double*,double*,double*,int*,double*,double*,int*,double*,int*,double*,int*,int*,int*,int*,double*,double*,double*,double*,double*,double*,double*,double*,double*,int*,int*
- callstatement (*f2py_func)(&iopt,x,y,w,&m,&xb,&xe,&k,&s,&nest,&tol,&maxit,&k1,&k2,&n,t,c,&fp,fpint,wrk,wrk+nest,wrk+nest*k2,wrk+nest*2*k2,wrk+nest*3*k2,nrdata,&ier)
-
- integer intent(hide) :: iopt = -1
- real*8 dimension(m),intent(in,out) :: x
- real*8 dimension(m),depend(m),check(len(y)==m),intent(in,out) :: y
- real*8 dimension(m),depend(m),check(len(w)==m),intent(in,out) :: w = 1.0
- integer intent(hide),depend(x),check(m>k),depend(k) :: m=len(x)
- real*8 intent(in,out),depend(x),check(xb<=x[0]) :: xb = x[0]
- real*8 intent(in,out),depend(x,m),check(xe>=x[m-1]) :: xe = x[m-1]
- integer check(1<=k && k<=5),intent(in,out) :: k
- real*8 intent(out) :: s = -1
- integer intent(hide),depend(n) :: nest = n
- real*8 intent(hide) :: tol = 0.001
- integer intent(hide) :: maxit = 20
- integer intent(hide),depend(k) :: k1=k+1
- integer intent(hide),depend(k) :: k2=k+2
- integer intent(out),depend(t) :: n = len(t)
- real*8 dimension(n),intent(in,out,overwrite) :: t
- real*8 dimension(nest),depend(nest),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(nest),depend(nest),intent(out,cache) :: fpint
- real*8 dimension(nest*3*k2+m*k1),intent(cache,hide),depend(nest,k1,k2,m) :: wrk
- integer dimension(nest),depend(nest),intent(out,cache) :: nrdata
- integer intent(out) :: ier
- end subroutine fpcurfm1
-
- !!!!!!!!!! Bivariate spline !!!!!!!!!!!
-
- subroutine bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk,iwrk,kwrk,ier)
- ! z,ier = bispev(tx,ty,c,kx,ky,x,y)
- real*8 dimension(nx),intent(in) :: tx
- integer intent(hide),depend(tx) :: nx=len(tx)
- real*8 dimension(ny),intent(in) :: ty
- integer intent(hide),depend(ty) :: ny=len(ty)
- real*8 intent(in),dimension((nx-kx-1)*(ny-ky-1)),depend(nx,ny,kx,ky),&
- check(len(c)==(nx-kx-1)*(ny-ky-1)):: c
- integer :: kx
- integer :: ky
- real*8 intent(in),dimension(mx) :: x
- integer intent(hide),depend(x) :: mx=len(x)
- real*8 intent(in),dimension(my) :: y
- integer intent(hide),depend(y) :: my=len(y)
- real*8 dimension(mx,my),depend(mx,my),intent(out,c) :: z
- real*8 dimension(lwrk),depend(lwrk),intent(hide,cache) :: wrk
- integer intent(hide),depend(mx,kx,my,ky) :: lwrk=mx*(kx+1)+my*(ky+1)
- integer dimension(kwrk),depend(kwrk),intent(hide,cache) :: iwrk
- integer intent(hide),depend(mx,my) :: kwrk=mx+my
- integer intent(out) :: ier
- end subroutine bispev
-
- subroutine surfit_smth(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,&
- nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,&
- iwrk,kwrk,ier)
- ! nx,tx,ny,ty,c,fp,ier = surfit_smth(x,y,z,[w,xb,xe,yb,ye,kx,ky,s,eps,lwrk2])
-
- fortranname surfit
-
- integer intent(hide) :: iopt=0
- integer intent(hide),depend(x,kx,ky),check(m>=(kx+1)*(ky+1)) &
- :: m=len(x)
- real*8 dimension(m) :: x
- real*8 dimension(m),depend(m),check(len(y)==m) :: y
- real*8 dimension(m),depend(m),check(len(z)==m) :: z
- real*8 optional,dimension(m),depend(m),check(len(w)==m) :: w = 1.0
- real*8 optional,depend(x,m) :: xb=dmin(x,m)
- real*8 optional,depend(x,m) :: xe=dmax(x,m)
- real*8 optional,depend(y,m) :: yb=dmin(y,m)
- real*8 optional,depend(y,m) :: ye=dmax(y,m)
- integer check(1<=kx && kx<=5) :: kx = 3
- integer check(1<=ky && ky<=5) :: ky = 3
- real*8 optional,check(0.0<=s) :: s = m
- integer optional,depend(kx,m),check(nxest>=2*(kx+1)) &
- :: nxest = imax(kx+1+sqrt(m/2),2*(kx+1))
- integer optional,depend(ky,m),check(nyest>=2*(ky+1)) &
- :: nyest = imax(ky+1+sqrt(m/2),2*(ky+1))
- integer intent(hide),depend(nxest,nyest) :: nmax=MAX(nxest,nyest)
- real*8 optional,check(0.0<eps && eps<1.0) :: eps = 1e-16
- integer intent(out) :: nx
- real*8 dimension(nmax),intent(out),depend(nmax) :: tx
- integer intent(out) :: ny
- real*8 dimension(nmax),intent(out),depend(nmax) :: ty
- real*8 dimension((nxest-kx-1)*(nyest-ky-1)), &
- depend(kx,ky,nxest,nyest),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(lwrk1),intent(cache,out),depend(lwrk1) :: wrk1
- integer intent(hide),depend(m,kx,ky,nxest,nyest) &
- :: lwrk1=calc_surfit_lwrk1(m,kx,ky,nxest,nyest)
- real*8 dimension(lwrk2),intent(cache,hide),depend(lwrk2) :: wrk2
- integer optional,intent(in),depend(kx,ky,nxest,nyest) &
- :: lwrk2=calc_surfit_lwrk2(m,kx,ky,nxest,nyest)
- integer dimension(kwrk),depend(kwrk),intent(cache,hide) :: iwrk
- integer intent(hide),depend(m,nxest,nyest,kx,ky) &
- :: kwrk=m+(nxest-2*kx-1)*(nyest-2*ky-1)
- integer intent(out) :: ier
- end subroutine surfit_smth
-
- subroutine surfit_lsq(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,&
- nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,&
- iwrk,kwrk,ier)
- ! tx,ty,c,fp,ier = surfit_lsq(x,y,z,tx,ty,[w,xb,xe,yb,ye,kx,ky,eps,lwrk2])
-
- fortranname surfit
-
- integer intent(hide) :: iopt=-1
- integer intent(hide),depend(x,kx,ky),check(m>=(kx+1)*(ky+1)) &
- :: m=len(x)
- real*8 dimension(m) :: x
- real*8 dimension(m),depend(m),check(len(y)==m) :: y
- real*8 dimension(m),depend(m),check(len(z)==m) :: z
- real*8 optional,dimension(m),depend(m),check(len(w)==m) :: w = 1.0
- real*8 optional,depend(x,tx,m,nx) :: xb=calc_b(x,m,tx,nx)
- real*8 optional,depend(x,tx,m,nx) :: xe=calc_e(x,m,tx,nx)
- real*8 optional,depend(y,ty,m,ny) :: yb=calc_b(y,m,ty,ny)
- real*8 optional,depend(y,ty,m,ny) :: ye=calc_e(y,m,ty,ny)
- integer check(1<=kx && kx<=5) :: kx = 3
- integer check(1<=ky && ky<=5) :: ky = 3
- real*8 intent(hide) :: s = 0.0
- integer intent(hide),depend(nx) :: nxest = nx
- integer intent(hide),depend(ny) :: nyest = ny
- integer intent(hide),depend(nx,ny) :: nmax=MAX(nx,ny)
- real*8 optional,check(0.0<eps && eps<1.0) :: eps = 1e-16
- integer intent(hide),depend(tx,kx),check(2*kx+2<=nx) :: nx = len(tx)
- real*8 dimension(nx),intent(in,out,overwrite) :: tx
- integer intent(hide),depend(ty,ky),check(2*ky+2<=ny) :: ny = len(ty)
- real*8 dimension(ny),intent(in,out,overwrite) :: ty
- real*8 dimension((nx-kx-1)*(ny-ky-1)),depend(kx,ky,nx,ny),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(lwrk1),intent(cache,hide),depend(lwrk1) :: wrk1
- integer intent(hide),depend(m,kx,ky,nxest,nyest) &
- :: lwrk1=calc_surfit_lwrk1(m,kx,ky,nxest,nyest)
- real*8 dimension(lwrk2),intent(cache,hide),depend(lwrk2) :: wrk2
- integer optional,intent(in),depend(kx,ky,nxest,nyest) &
- :: lwrk2=calc_surfit_lwrk2(m,kx,ky,nxest,nyest)
- integer dimension(kwrk),depend(kwrk),intent(cache,hide) :: iwrk
- integer intent(hide),depend(m,nx,ny,kx,ky) &
- :: kwrk=m+(nx-2*kx-1)*(ny-2*ky-1)
- integer intent(out) :: ier
- end subroutine surfit_lsq
-
- subroutine regrid_smth(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,&
- nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
- ! nx,tx,ny,ty,c,fp,ier = regrid_smth(x,y,z,[xb,xe,yb,ye,kx,ky,s])
-
- fortranname regrid
-
- integer intent(hide) :: iopt=0
- integer intent(hide),depend(x,kx),check(mx>kx) :: mx=len(x)
- real*8 dimension(mx) :: x
- integer intent(hide),depend(y,ky),check(my>ky) :: my=len(y)
- real*8 dimension(my) :: y
- real*8 dimension(mx*my),depend(mx,my),check(len(z)==mx*my) :: z
- real*8 optional,depend(x,mx) :: xb=dmin(x,mx)
- real*8 optional,depend(x,mx) :: xe=dmax(x,mx)
- real*8 optional,depend(y,my) :: yb=dmin(y,my)
- real*8 optional,depend(y,my) :: ye=dmax(y,my)
- integer optional,check(1<=kx && kx<=5) :: kx = 3
- integer optional,check(1<=ky && ky<=5) :: ky = 3
- real*8 optional,check(0.0<=s) :: s = 0.0
- integer intent(hide),depend(kx,mx),check(nxest>=2*(kx+1)) &
- :: nxest = mx+kx+1
- integer intent(hide),depend(ky,my),check(nyest>=2*(ky+1)) &
- :: nyest = my+ky+1
- integer intent(out) :: nx
- real*8 dimension(nxest),intent(out),depend(nxest) :: tx
- integer intent(out) :: ny
- real*8 dimension(nyest),intent(out),depend(nyest) :: ty
- real*8 dimension((nxest-kx-1)*(nyest-ky-1)), &
- depend(kx,ky,nxest,nyest),intent(out) :: c
- real*8 intent(out) :: fp
- real*8 dimension(lwrk),intent(cache,hide),depend(lwrk) :: wrk
- integer intent(hide),depend(mx,my,kx,ky,nxest,nyest) &
- :: lwrk=calc_regrid_lwrk(mx,my,kx,ky,nxest,nyest)
- integer dimension(kwrk),depend(kwrk),intent(cache,hide) :: iwrk
- integer intent(hide),depend(mx,my,nxest,nyest) &
- :: kwrk=3+mx+my+nxest+nyest
- integer intent(out) :: ier
- end subroutine regrid_smth
-
- function dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk)
- ! iy = dblint(tx,ty,c,kx,ky,xb,xe,yb,ye)
- real*8 dimension(nx),intent(in) :: tx
- integer intent(hide),depend(tx) :: nx=len(tx)
- real*8 dimension(ny),intent(in) :: ty
- integer intent(hide),depend(ty) :: ny=len(ty)
- real*8 intent(in),dimension((nx-kx-1)*(ny-ky-1)),depend(nx,ny,kx,ky),&
- check(len(c)==(nx-kx-1)*(ny-ky-1)):: c
- integer :: kx
- integer :: ky
- real*8 intent(in) :: xb
- real*8 intent(in) :: xe
- real*8 intent(in) :: yb
- real*8 intent(in) :: ye
- real*8 dimension(nx+ny-kx-ky-2),depend(nx,ny,kx,ky),intent(cache,hide) :: wrk
- real*8 :: dblint
- end function dblint
- end interface
-end python module _dfitpack
-
Deleted: branches/Interpolate1D/_interpolate.cpp
===================================================================
--- branches/Interpolate1D/_interpolate.cpp 2008-08-07 21:05:37 UTC (rev 4609)
+++ branches/Interpolate1D/_interpolate.cpp 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,236 +0,0 @@
-#include "Python.h"
-#include <stdlib.h>
-
-#include "interpolate.h"
-#include "numpy/arrayobject.h"
-
-using namespace std;
-
-extern "C" {
-
-static PyObject* linear_method(PyObject*self, PyObject* args, PyObject* kywds)
-{
- static char *kwlist[] = {"x","y","new_x","new_y", NULL};
- PyObject *py_x, *py_y, *py_new_x, *py_new_y;
- py_x = py_y = py_new_x = py_new_y = NULL;
- PyObject *arr_x, *arr_y, *arr_new_x, *arr_new_y;
- arr_x = arr_y = arr_new_x = arr_new_y = NULL;
-
- if(!PyArg_ParseTupleAndKeywords(args,kywds,"OOOO:linear_dddd",kwlist,&py_x, &py_y, &py_new_x, &py_new_y))
- return NULL;
- arr_x = PyArray_FROMANY(py_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_x) {
- PyErr_SetString(PyExc_ValueError, "x must be a 1-D array of floats");
- goto fail;
- }
- arr_y = PyArray_FROMANY(py_y, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_y) {
- PyErr_SetString(PyExc_ValueError, "y must be a 1-D array of floats");
- goto fail;
- }
- arr_new_x = PyArray_FROMANY(py_new_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_new_x) {
- PyErr_SetString(PyExc_ValueError, "new_x must be a 1-D array of floats");
- goto fail;
- }
- arr_new_y = PyArray_FROMANY(py_new_y, PyArray_DOUBLE, 1, 1, NPY_INOUT_ARRAY);
- if (!arr_new_y) {
- PyErr_SetString(PyExc_ValueError, "new_y must be a 1-D array of floats");
- goto fail;
- }
-
- linear((double*)PyArray_DATA(arr_x), (double*)PyArray_DATA(arr_y),
- PyArray_DIM(arr_x,0), (double*)PyArray_DATA(arr_new_x),
- (double*)PyArray_DATA(arr_new_y), PyArray_DIM(arr_new_x,0));
-
- Py_DECREF(arr_x);
- Py_DECREF(arr_y);
- Py_DECREF(arr_new_x);
- Py_DECREF(arr_new_y);
-
- Py_RETURN_NONE;
-
-fail:
- Py_XDECREF(arr_x);
- Py_XDECREF(arr_y);
- Py_XDECREF(arr_new_x);
- Py_XDECREF(arr_new_y);
- return NULL;
-}
-
-static PyObject* loginterp_method(PyObject*self, PyObject* args, PyObject* kywds)
-{
- static char *kwlist[] = {"x","y","new_x","new_y", NULL};
- PyObject *py_x, *py_y, *py_new_x, *py_new_y;
- py_x = py_y = py_new_x = py_new_y = NULL;
- PyObject *arr_x, *arr_y, *arr_new_x, *arr_new_y;
- arr_x = arr_y = arr_new_x = arr_new_y = NULL;
-
- if(!PyArg_ParseTupleAndKeywords(args,kywds,"OOOO:loginterp_dddd",kwlist,&py_x, &py_y, &py_new_x, &py_new_y))
- return NULL;
- arr_x = PyArray_FROMANY(py_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_x) {
- PyErr_SetString(PyExc_ValueError, "x must be a 1-D array of floats");
- goto fail;
- }
- arr_y = PyArray_FROMANY(py_y, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_y) {
- PyErr_SetString(PyExc_ValueError, "y must be a 1-D array of floats");
- goto fail;
- }
- arr_new_x = PyArray_FROMANY(py_new_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_new_x) {
- PyErr_SetString(PyExc_ValueError, "new_x must be a 1-D array of floats");
- goto fail;
- }
- arr_new_y = PyArray_FROMANY(py_new_y, PyArray_DOUBLE, 1, 1, NPY_INOUT_ARRAY);
- if (!arr_new_y) {
- PyErr_SetString(PyExc_ValueError, "new_y must be a 1-D array of floats");
- goto fail;
- }
-
- loginterp((double*)PyArray_DATA(arr_x), (double*)PyArray_DATA(arr_y),
- PyArray_DIM(arr_x,0), (double*)PyArray_DATA(arr_new_x),
- (double*)PyArray_DATA(arr_new_y), PyArray_DIM(arr_new_x,0));
-
- Py_DECREF(arr_x);
- Py_DECREF(arr_y);
- Py_DECREF(arr_new_x);
- Py_DECREF(arr_new_y);
-
- Py_RETURN_NONE;
-
-fail:
- Py_XDECREF(arr_x);
- Py_XDECREF(arr_y);
- Py_XDECREF(arr_new_x);
- Py_XDECREF(arr_new_y);
- return NULL;
-}
-
-static PyObject* window_average_method(PyObject*self, PyObject* args, PyObject* kywds)
-{
- static char *kwlist[] = {"x","y","new_x","new_y", NULL};
- PyObject *py_x, *py_y, *py_new_x, *py_new_y;
- py_x = py_y = py_new_x = py_new_y = NULL;
- PyObject *arr_x, *arr_y, *arr_new_x, *arr_new_y;
- arr_x = arr_y = arr_new_x = arr_new_y = NULL;
- double width;
-
- if(!PyArg_ParseTupleAndKeywords(args,kywds,"OOOOd:loginterp_dddd",kwlist,&py_x, &py_y, &py_new_x, &py_new_y, &width))
- return NULL;
- arr_x = PyArray_FROMANY(py_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_x) {
- PyErr_SetString(PyExc_ValueError, "x must be a 1-D array of floats");
- goto fail;
- }
- arr_y = PyArray_FROMANY(py_y, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_y) {
- PyErr_SetString(PyExc_ValueError, "y must be a 1-D array of floats");
- goto fail;
- }
- arr_new_x = PyArray_FROMANY(py_new_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_new_x) {
- PyErr_SetString(PyExc_ValueError, "new_x must be a 1-D array of floats");
- goto fail;
- }
- arr_new_y = PyArray_FROMANY(py_new_y, PyArray_DOUBLE, 1, 1, NPY_INOUT_ARRAY);
- if (!arr_new_y) {
- PyErr_SetString(PyExc_ValueError, "new_y must be a 1-D array of floats");
- goto fail;
- }
-
- window_average((double*)PyArray_DATA(arr_x), (double*)PyArray_DATA(arr_y),
- PyArray_DIM(arr_x,0), (double*)PyArray_DATA(arr_new_x),
- (double*)PyArray_DATA(arr_new_y), PyArray_DIM(arr_new_x,0), width);
-
- Py_DECREF(arr_x);
- Py_DECREF(arr_y);
- Py_DECREF(arr_new_x);
- Py_DECREF(arr_new_y);
-
- Py_RETURN_NONE;
-
-fail:
- Py_XDECREF(arr_x);
- Py_XDECREF(arr_y);
- Py_XDECREF(arr_new_x);
- Py_XDECREF(arr_new_y);
- return NULL;
-}
-
-static PyObject* block_average_above_method(PyObject*self, PyObject* args, PyObject* kywds)
-{
- static char *kwlist[] = {"x","y","new_x","new_y", NULL};
- PyObject *py_x, *py_y, *py_new_x, *py_new_y;
- py_x = py_y = py_new_x = py_new_y = NULL;
- PyObject *arr_x, *arr_y, *arr_new_x, *arr_new_y;
- arr_x = arr_y = arr_new_x = arr_new_y = NULL;
-
- if(!PyArg_ParseTupleAndKeywords(args,kywds,"OOOO:loginterp_dddd",kwlist,&py_x, &py_y, &py_new_x, &py_new_y))
- return NULL;
- arr_x = PyArray_FROMANY(py_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_x) {
- PyErr_SetString(PyExc_ValueError, "x must be a 1-D array of floats");
- goto fail;
- }
- arr_y = PyArray_FROMANY(py_y, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_y) {
- PyErr_SetString(PyExc_ValueError, "y must be a 1-D array of floats");
- goto fail;
- }
- arr_new_x = PyArray_FROMANY(py_new_x, PyArray_DOUBLE, 1, 1, NPY_IN_ARRAY);
- if (!arr_new_x) {
- PyErr_SetString(PyExc_ValueError, "new_x must be a 1-D array of floats");
- goto fail;
- }
- arr_new_y = PyArray_FROMANY(py_new_y, PyArray_DOUBLE, 1, 1, NPY_INOUT_ARRAY);
- if (!arr_new_y) {
- PyErr_SetString(PyExc_ValueError, "new_y must be a 1-D array of floats");
- goto fail;
- }
-
- block_average_above((double*)PyArray_DATA(arr_x), (double*)PyArray_DATA(arr_y),
- PyArray_DIM(arr_x,0), (double*)PyArray_DATA(arr_new_x),
- (double*)PyArray_DATA(arr_new_y), PyArray_DIM(arr_new_x,0));
-
- Py_DECREF(arr_x);
- Py_DECREF(arr_y);
- Py_DECREF(arr_new_x);
- Py_DECREF(arr_new_y);
-
- Py_RETURN_NONE;
-
-fail:
- Py_XDECREF(arr_x);
- Py_XDECREF(arr_y);
- Py_XDECREF(arr_new_x);
- Py_XDECREF(arr_new_y);
- return NULL;
-}
-
-static PyMethodDef interpolate_methods[] = {
- {"linear_dddd", (PyCFunction)linear_method, METH_VARARGS|METH_KEYWORDS,
- ""},
- {"loginterp_dddd", (PyCFunction)loginterp_method, METH_VARARGS|METH_KEYWORDS,
- ""},
- {"window_average_ddddd", (PyCFunction)window_average_method, METH_VARARGS|METH_KEYWORDS,
- ""},
- {"block_average_above_dddd", (PyCFunction)block_average_above_method, METH_VARARGS|METH_KEYWORDS,
- ""},
- {NULL, NULL, 0, NULL}
-};
-
-
-PyMODINIT_FUNC init_interpolate(void)
-{
- PyObject* m;
- m = Py_InitModule3("_interpolate", interpolate_methods,
- "A few interpolation routines.\n"
- );
- if (m == NULL)
- return;
- import_array();
-}
-
-} // extern "C"
Copied: branches/Interpolate1D/extensions/_fitpack.pyf (from rev 4591, branches/Interpolate1D/_fitpack.pyf)
Copied: branches/Interpolate1D/extensions/_interpolate.cpp (from rev 4587, branches/Interpolate1D/_interpolate.cpp)
Copied: branches/Interpolate1D/extensions/fitpack (from rev 4587, branches/Interpolate1D/fitpack)
Copied: branches/Interpolate1D/extensions/fitpack/fitpack (from rev 4587, branches/Interpolate1D/fitpack)
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/Makefile
===================================================================
--- branches/Interpolate1D/fitpack/Makefile 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/Makefile 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,19 +0,0 @@
-# Makefile that builts a library lib$(LIB).a from all
-# of the Fortran files found in the current directory.
-# Usage: make LIB=<libname>
-# Pearu
-
-OBJ=$(patsubst %.f,%.o,$(shell ls *.f))
-all: lib$(LIB).a
-$(OBJ):
- $(FC) -c $(FFLAGS) $(FSHARED) $(patsubst %.o,%.f,$(@F)) -o $@
-lib$(LIB).a: $(OBJ)
- $(AR) rus lib$(LIB).a $?
-clean:
- rm *.o
-
-
-
-
-
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/README
===================================================================
--- branches/Interpolate1D/fitpack/README 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/README 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,3 +0,0 @@
-- ddierckx is a 'real*8' version of dierckx
- generated by Pearu Peterson <pearu at ioc.ee>.
-- dierckx (in netlib) is fitpack by P. Dierckx
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/bispev.f
===================================================================
--- branches/Interpolate1D/fitpack/bispev.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/bispev.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,103 +0,0 @@
- subroutine bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk,
- * iwrk,kwrk,ier)
-c subroutine bispev evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,...
-c ,my a bivariate spline s(x,y) of degrees kx and ky, given in the
-c b-spline representation.
-c
-c calling sequence:
-c call bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk,
-c * iwrk,kwrk,ier)
-c
-c input parameters:
-c tx : real array, length nx, which contains the position of the
-c knots in the x-direction.
-c nx : integer, giving the total number of knots in the x-direction
-c ty : real array, length ny, which contains the position of the
-c knots in the y-direction.
-c ny : integer, giving the total number of knots in the y-direction
-c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the
-c b-spline coefficients.
-c kx,ky : integer values, giving the degrees of the spline.
-c x : real array of dimension (mx).
-c before entry x(i) must be set to the x co-ordinate of the
-c i-th grid point along the x-axis.
-c tx(kx+1)<=x(i-1)<=x(i)<=tx(nx-kx), i=2,...,mx.
-c mx : on entry mx must specify the number of grid points along
-c the x-axis. mx >=1.
-c y : real array of dimension (my).
-c before entry y(j) must be set to the y co-ordinate of the
-c j-th grid point along the y-axis.
-c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my.
-c my : on entry my must specify the number of grid points along
-c the y-axis. my >=1.
-c wrk : real array of dimension lwrk. used as workspace.
-c lwrk : integer, specifying the dimension of wrk.
-c lwrk >= mx*(kx+1)+my*(ky+1)
-c iwrk : integer array of dimension kwrk. used as workspace.
-c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my.
-c
-c output parameters:
-c z : real array of dimension (mx*my).
-c on succesful exit z(my*(i-1)+j) contains the value of s(x,y)
-c at the point (x(i),y(j)),i=1,...,mx;j=1,...,my.
-c ier : integer error flag
-c ier=0 : normal return
-c ier=10: invalid input data (see restrictions)
-c
-c restrictions:
-c mx >=1, my >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my
-c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx
-c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my
-c
-c other subroutines required:
-c fpbisp,fpbspl
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer nx,ny,kx,ky,mx,my,lwrk,kwrk,ier
-c ..array arguments..
- integer iwrk(kwrk)
- real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my),
- * wrk(lwrk)
-c ..local scalars..
- integer i,iw,lwest
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- lwest = (kx+1)*mx+(ky+1)*my
- if(lwrk.lt.lwest) go to 100
- if(kwrk.lt.(mx+my)) go to 100
- if (mx.lt.1) go to 100
- if (mx.eq.1) go to 30
- go to 10
- 10 do 20 i=2,mx
- if(x(i).lt.x(i-1)) go to 100
- 20 continue
- 30 if (my.lt.1) go to 100
- if (my.eq.1) go to 60
- go to 40
- 40 do 50 i=2,my
- if(y(i).lt.y(i-1)) go to 100
- 50 continue
- 60 ier = 0
- iw = mx*(kx+1)+1
- call fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk(1),wrk(iw),
- * iwrk(1),iwrk(mx+1))
- 100 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/clocur.f
===================================================================
--- branches/Interpolate1D/fitpack/clocur.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/clocur.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,352 +0,0 @@
- subroutine clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c,fp,
- * wrk,lwrk,iwrk,ier)
-c given the ordered set of m points x(i) in the idim-dimensional space
-c with x(1)=x(m), and given also a corresponding set of strictly in-
-c creasing values u(i) and the set of positive numbers w(i),i=1,2,...,m
-c subroutine clocur determines a smooth approximating closed spline
-c curve s(u), i.e.
-c x1 = s1(u)
-c x2 = s2(u) u(1) <= u <= u(m)
-c .........
-c xidim = sidim(u)
-c with sj(u),j=1,2,...,idim periodic spline functions of degree k with
-c common knots t(j),j=1,2,...,n.
-c if ipar=1 the values u(i),i=1,2,...,m must be supplied by the user.
-c if ipar=0 these values are chosen automatically by clocur as
-c v(1) = 0
-c v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m
-c u(i) = v(i)/v(m) ,i=1,2,...,m
-c if iopt=-1 clocur calculates the weighted least-squares closed spline
-c curve according to a given set of knots.
-c if iopt>=0 the number of knots of the splines sj(u) and the position
-c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
-c ness of s(u) is then achieved by minimalizing the discontinuity
-c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,...,
-c n-k-1. the amount of smoothness is determined by the condition that
-c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non-
-c negative constant, called the smoothing factor.
-c the fit s(u) is given in the b-spline representation and can be
-c evaluated by means of subroutine curev.
-c
-c calling sequence:
-c call clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c,
-c * fp,wrk,lwrk,iwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares closed spline curve (iopt=-1) or a smoothing
-c closed spline curve (iopt=0 or 1) must be determined. if
-c iopt=0 the routine will start with an initial set of knots
-c t(i)=u(1)+(u(m)-u(1))*(i-k-1),i=1,2,...,2*k+2. if iopt=1 the
-c routine will continue with the knots found at the last call.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c ipar : integer flag. on entry ipar must specify whether (ipar=1)
-c the user will supply the parameter values u(i),or whether
-c (ipar=0) these values are to be calculated by clocur.
-c unchanged on exit.
-c idim : integer. on entry idim must specify the dimension of the
-c curve. 0 < idim < 11.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m > 1. unchanged on exit.
-c u : real array of dimension at least (m). in case ipar=1,before
-c entry, u(i) must be set to the i-th value of the parameter
-c variable u for i=1,2,...,m. these values must then be
-c supplied in strictly ascending order and will be unchanged
-c on exit. in case ipar=0, on exit,the array will contain the
-c values u(i) as determined by clocur.
-c mx : integer. on entry mx must specify the actual dimension of
-c the array x as declared in the calling (sub)program. mx must
-c not be too small (see x). unchanged on exit.
-c x : real array of dimension at least idim*m.
-c before entry, x(idim*(i-1)+j) must contain the j-th coord-
-c inate of the i-th data point for i=1,2,...,m and j=1,2,...,
-c idim. since first and last data point must coincide it
-c means that x(j)=x(idim*(m-1)+j),j=1,2,...,idim.
-c unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. w(m) is not used.
-c unchanged on exit. see also further comments.
-c k : integer. on entry k must specify the degree of the splines.
-c 1<=k<=5. it is recommended to use cubic splines (k=3).
-c the user is strongly dissuaded from choosing k even,together
-c with a small s-value. unchanged on exit.
-c s : real.on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments.
-c nest : integer. on entry nest must contain an over-estimate of the
-c total number of knots of the splines returned, to indicate
-c the storage space available to the routine. nest >=2*k+2.
-c in most practical situation nest=m/2 will be sufficient.
-c always large enough is nest=m+2*k, the number of knots
-c needed for interpolation (s=0). unchanged on exit.
-c n : integer.
-c unless ier = 10 (in case iopt >=0), n will contain the
-c total number of knots of the smoothing spline curve returned
-c if the computation mode iopt=1 is used this value of n
-c should be left unchanged between subsequent calls.
-c in case iopt=-1, the value of n must be specified on entry.
-c t : real array of dimension at least (nest).
-c on succesful exit, this array will contain the knots of the
-c spline curve,i.e. the position of the interior knots t(k+2),
-c t(k+3),..,t(n-k-1) as well as the position of the additional
-c t(1),t(2),..,t(k+1)=u(1) and u(m)=t(n-k),...,t(n) needed for
-c the b-spline representation.
-c if the computation mode iopt=1 is used, the values of t(1),
-c t(2),...,t(n) should be left unchanged between subsequent
-c calls. if the computation mode iopt=-1 is used, the values
-c t(k+2),...,t(n-k-1) must be supplied by the user, before
-c entry. see also the restrictions (ier=10).
-c nc : integer. on entry nc must specify the actual dimension of
-c the array c as declared in the calling (sub)program. nc
-c must not be too small (see c). unchanged on exit.
-c c : real array of dimension at least (nest*idim).
-c on succesful exit, this array will contain the coefficients
-c in the b-spline representation of the spline curve s(u),i.e.
-c the b-spline coefficients of the spline sj(u) will be given
-c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim.
-c fp : real. unless ier = 10, fp contains the weighted sum of
-c squared residuals of the spline curve returned.
-c wrk : real array of dimension at least m*(k+1)+nest*(7+idim+5*k).
-c used as working space. if the computation mode iopt=1 is
-c used, the values wrk(1),...,wrk(n) should be left unchanged
-c between subsequent calls.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program. lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (nest).
-c used as working space. if the computation mode iopt=1 is
-c used,the values iwrk(1),...,iwrk(n) should be left unchanged
-c between subsequent calls.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the close curve returned has a residual
-c sum of squares fp such that abs(fp-s)/s <= tol with tol a
-c relative tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the curve returned is an interpolating
-c spline curve (fp=0).
-c ier=-2 : normal return. the curve returned is the weighted least-
-c squares point,i.e. each spline sj(u) is a constant. in
-c this extreme case fp gives the upper bound fp0 for the
-c smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameter nest.
-c probably causes : nest too small. if nest is already
-c large (say nest > m/2), it may also indicate that s is
-c too small
-c the approximation returned is the least-squares closed
-c curve according to the knots t(1),t(2),...,t(n). (n=nest)
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing curve with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing curve
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,2,...,m
-c 0<=ipar<=1, 0<idim<=10, lwrk>=(k+1)*m+nest*(7+idim+5*k),
-c nc>=nest*idim, x(j)=x(idim*(m-1)+j), j=1,2,...,idim
-c if ipar=0: sum j=1,idim (x(i*idim+j)-x((i-1)*idim+j))**2>0
-c i=1,2,...,m-1.
-c if ipar=1: u(1)<u(2)<...<u(m)
-c if iopt=-1: 2*k+2<=n<=min(nest,m+2*k)
-c u(1)<t(k+2)<t(k+3)<...<t(n-k-1)<u(m)
-c (u(1)=0 and u(m)=1 in case ipar=0)
-c the schoenberg-whitney conditions, i.e. there
-c must be a subset of data points uu(j) with
-c uu(j) = u(i) or u(i)+(u(m)-u(1)) such that
-c t(j) < uu(j) < t(j+k+1), j=k+1,...,n-k-1
-c if iopt>=0: s>=0
-c if s=0 : nest >= m+2*k
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the curve will be too smooth and signal will be
-c lost ; if s is too small the curve will pick up too much noise. in
-c the extreme cases the program will return an interpolating curve if
-c s=0 and the weighted least-squares point if s is very large.
-c between these extremes, a properly chosen s will result in a good
-c compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in x(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the weighted
-c least-squares point and the upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximating curve shows more detail) to obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if clocur is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c curve underlying the data. but, if the computation mode iopt=1 is
-c used, the knots returned may also depend on the s-values at previous
-c calls (if these were smaller). therefore, if after a number of
-c trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c clocur once more with the selected value for s but now with iopt=0.
-c indeed, clocur may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c
-c the form of the approximating curve can strongly be affected by
-c the choice of the parameter values u(i). if there is no physical
-c reason for choosing a particular parameter u, often good results
-c will be obtained with the choice of clocur(in case ipar=0), i.e.
-c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m
-c where
-c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 )
-c other possibilities for q(i) are
-c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2
-c q(i)= sum j=1,idim abs(xj(i)-xj(i-1))
-c q(i)= max j=1,idim abs(xj(i)-xj(i-1))
-c q(i)= 1
-c
-c
-c other subroutines required:
-c fpbacp,fpbspl,fpchep,fpclos,fpdisc,fpgivs,fpknot,fprati,fprota
-c
-c references:
-c dierckx p. : algorithms for smoothing data with periodic and
-c parametric splines, computer graphics and image
-c processing 20 (1982) 171-184.
-c dierckx p. : algorithms for smoothing data with periodic and param-
-c etric splines, report tw55, dept. computer science,
-c k.u.leuven, 1981.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- real*8 s,fp
- integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier
-c ..array arguments..
- real*8 u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk)
- integer iwrk(nest)
-c ..local scalars..
- real*8 per,tol,dist
- integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest,
- * maxit,m1,nmin,ncc,j
-c ..function references..
- real*8 sqrt
-c we set up the parameters tol and maxit
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 90
- if(ipar.lt.0 .or. ipar.gt.1) go to 90
- if(idim.le.0 .or. idim.gt.10) go to 90
- if(k.le.0 .or. k.gt.5) go to 90
- k1 = k+1
- k2 = k1+1
- nmin = 2*k1
- if(m.lt.2 .or. nest.lt.nmin) go to 90
- ncc = nest*idim
- if(mx.lt.m*idim .or. nc.lt.ncc) go to 90
- lwest = m*k1+nest*(7+idim+5*k)
- if(lwrk.lt.lwest) go to 90
- i1 = idim
- i2 = m*idim
- do 5 j=1,idim
- if(x(i1).ne.x(i2)) go to 90
- i1 = i1-1
- i2 = i2-1
- 5 continue
- if(ipar.ne.0 .or. iopt.gt.0) go to 40
- i1 = 0
- i2 = idim
- u(1) = 0.
- do 20 i=2,m
- dist = 0.
- do 10 j1=1,idim
- i1 = i1+1
- i2 = i2+1
- dist = dist+(x(i2)-x(i1))**2
- 10 continue
- u(i) = u(i-1)+sqrt(dist)
- 20 continue
- if(u(m).le.0.) go to 90
- do 30 i=2,m
- u(i) = u(i)/u(m)
- 30 continue
- u(m) = 0.1e+01
- 40 if(w(1).le.0.) go to 90
- m1 = m-1
- do 50 i=1,m1
- if(u(i).ge.u(i+1) .or. w(i).le.0.) go to 90
- 50 continue
- if(iopt.ge.0) go to 70
- if(n.le.nmin .or. n.gt.nest) go to 90
- per = u(m)-u(1)
- j1 = k1
- t(j1) = u(1)
- i1 = n-k
- t(i1) = u(m)
- j2 = j1
- i2 = i1
- do 60 i=1,k
- i1 = i1+1
- i2 = i2-1
- j1 = j1+1
- j2 = j2-1
- t(j2) = t(i2)-per
- t(i1) = t(j1)+per
- 60 continue
- call fpchep(u,m,t,n,k,ier)
- if (ier.eq.0) go to 80
- go to 90
- 70 if(s.lt.0.) go to 90
- if(s.eq.0. .and. nest.lt.(m+2*k)) go to 90
- ier = 0
-c we partition the working space and determine the spline approximation.
- 80 ifp = 1
- iz = ifp+nest
- ia1 = iz+ncc
- ia2 = ia1+nest*k1
- ib = ia2+nest*k
- ig1 = ib+nest*k2
- ig2 = ig1+nest*k2
- iq = ig2+nest*k1
- call fpclos(iopt,idim,m,u,mx,x,w,k,s,nest,tol,maxit,k1,k2,n,t,
- * ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1),
- * wrk(ig2),wrk(iq),iwrk,ier)
- 90 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/cocosp.f
===================================================================
--- branches/Interpolate1D/fitpack/cocosp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/cocosp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,180 +0,0 @@
- subroutine cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk,
- * lwrk,iwrk,kwrk,ier)
-c given the set of data points (x(i),y(i)) and the set of positive
-c numbers w(i),i=1,2,...,m, subroutine cocosp determines the weighted
-c least-squares cubic spline s(x) with given knots t(j),j=1,2,...,n
-c which satisfies the following concavity/convexity conditions
-c s''(t(j+3))*e(j) <= 0, j=1,2,...n-6
-c the fit is given in the b-spline representation( b-spline coef-
-c ficients c(j),j=1,2,...n-4) and can be evaluated by means of
-c subroutine splev.
-c
-c calling sequence:
-c call cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk,
-c * lwrk,iwrk,kwrk,ier)
-c
-c parameters:
-c m : integer. on entry m must specify the number of data points.
-c m > 3. unchanged on exit.
-c x : real array of dimension at least (m). before entry, x(i)
-c must be set to the i-th value of the independent variable x,
-c for i=1,2,...,m. these values must be supplied in strictly
-c ascending order. unchanged on exit.
-c y : real array of dimension at least (m). before entry, y(i)
-c must be set to the i-th value of the dependent variable y,
-c for i=1,2,...,m. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. unchanged on exit.
-c n : integer. on entry n must contain the total number of knots
-c of the cubic spline. m+4>=n>=8. unchanged on exit.
-c t : real array of dimension at least (n). before entry, this
-c array must contain the knots of the spline, i.e. the position
-c of the interior knots t(5),t(6),...,t(n-4) as well as the
-c position of the boundary knots t(1),t(2),t(3),t(4) and t(n-3)
-c t(n-2),t(n-1),t(n) needed for the b-spline representation.
-c unchanged on exit. see also the restrictions (ier=10).
-c e : real array of dimension at least (n). before entry, e(j)
-c must be set to 1 if s(x) must be locally concave at t(j+3),
-c to (-1) if s(x) must be locally convex at t(j+3) and to 0
-c if no convexity constraint is imposed at t(j+3),j=1,2,..,n-6.
-c e(n-5),...,e(n) are not used. unchanged on exit.
-c maxtr : integer. on entry maxtr must contain an over-estimate of the
-c total number of records in the used tree structure, to indic-
-c ate the storage space available to the routine. maxtr >=1
-c in most practical situation maxtr=100 will be sufficient.
-c always large enough is
-c n-5 n-6
-c maxtr = ( ) + ( ) with l the greatest
-c l l+1
-c integer <= (n-6)/2 . unchanged on exit.
-c maxbin: integer. on entry maxbin must contain an over-estimate of the
-c number of knots where s(x) will have a zero second derivative
-c maxbin >=1. in most practical situation maxbin = 10 will be
-c sufficient. always large enough is maxbin=n-6.
-c unchanged on exit.
-c c : real array of dimension at least (n).
-c on succesful exit, this array will contain the coefficients
-c c(1),c(2),..,c(n-4) in the b-spline representation of s(x)
-c sq : real. on succesful exit, sq contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c sx : real array of dimension at least m. on succesful exit
-c this array will contain the spline values s(x(i)),i=1,...,m
-c bind : logical array of dimension at least (n). on succesful exit
-c this array will indicate the knots where s''(x)=0, i.e.
-c s''(t(j+3)) .eq. 0 if bind(j) = .true.
-c s''(t(j+3)) .ne. 0 if bind(j) = .false., j=1,2,...,n-6
-c wrk : real array of dimension at least m*4+n*7+maxbin*(maxbin+n+1)
-c used as working space.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1))
-c used as working space.
-c kwrk : integer. on entry,kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program. kwrk
-c must not be too small (see iwrk). unchanged on exit.
-c ier : integer. error flag
-c ier=0 : succesful exit.
-c ier>0 : abnormal termination: no approximation is returned
-c ier=1 : the number of knots where s''(x)=0 exceeds maxbin.
-c probably causes : maxbin too small.
-c ier=2 : the number of records in the tree structure exceeds
-c maxtr.
-c probably causes : maxtr too small.
-c ier=3 : the algoritm finds no solution to the posed quadratic
-c programming problem.
-c probably causes : rounding errors.
-c ier=10 : on entry, the input data are controlled on validity.
-c the following restrictions must be satisfied
-c m>3, maxtr>=1, maxbin>=1, 8<=n<=m+4,w(i) > 0,
-c x(1)<x(2)<...<x(m), t(1)<=t(2)<=t(3)<=t(4)<=x(1),
-c x(1)<t(5)<t(6)<...<t(n-4)<x(m)<=t(n-3)<=...<=t(n),
-c kwrk>=maxtr*4+2*(maxbin+1),
-c lwrk>=m*4+n*7+maxbin*(maxbin+n+1),
-c the schoenberg-whitney conditions, i.e. there must
-c be a subset of data points xx(j) such that
-c t(j) < xx(j) < t(j+4), j=1,2,...,n-4
-c if one of these restrictions is found to be violated
-c control is immediately repassed to the calling program
-c
-c
-c other subroutines required:
-c fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno,fpchec
-c
-c references:
-c dierckx p. : an algorithm for cubic spline fitting with convexity
-c constraints, computing 24 (1980) 349-371.
-c dierckx p. : an algorithm for least-squares cubic spline fitting
-c with convexity and concavity constraints, report tw39,
-c dept. computer science, k.u.leuven, 1978.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p. dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : march 1978
-c latest update : march 1987.
-c
-c ..
-c ..scalar arguments..
- real*8 sq
- integer m,n,maxtr,maxbin,lwrk,kwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),t(n),e(n),c(n),sx(m),wrk(lwrk)
- integer iwrk(kwrk)
- logical bind(n)
-c ..local scalars..
- integer i,ia,ib,ic,iq,iu,iz,izz,ji,jib,jjb,jl,jr,ju,kwest,
- * lwest,mb,nm,n6
- real*8 one
-c ..
-c set constant
- one = 0.1e+01
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(m.lt.4 .or. n.lt.8) go to 40
- if(maxtr.lt.1 .or. maxbin.lt.1) go to 40
- lwest = 7*n+m*4+maxbin*(1+n+maxbin)
- kwest = 4*maxtr+2*(maxbin+1)
- if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 40
- if(w(1).le.0.) go to 40
- do 10 i=2,m
- if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 40
- 10 continue
- call fpchec(x,m,t,n,3,ier)
- if (ier.eq.0) go to 20
- go to 40
-c set numbers e(i)
- 20 n6 = n-6
- do 30 i=1,n6
- if(e(i).gt.0.) e(i) = one
- if(e(i).lt.0.) e(i) = -one
- 30 continue
-c we partition the working space and determine the spline approximation
- nm = n+maxbin
- mb = maxbin+1
- ia = 1
- ib = ia+4*n
- ic = ib+nm*maxbin
- iz = ic+n
- izz = iz+n
- iu = izz+n
- iq = iu+maxbin
- ji = 1
- ju = ji+maxtr
- jl = ju+maxtr
- jr = jl+maxtr
- jjb = jr+maxtr
- jib = jjb+mb
- call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia),
- *
- * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji),
- * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier)
- 40 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/concon.f
===================================================================
--- branches/Interpolate1D/fitpack/concon.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/concon.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,233 +0,0 @@
- subroutine concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,
- * sx,bind,wrk,lwrk,iwrk,kwrk,ier)
-c given the set of data points (x(i),y(i)) and the set of positive
-c numbers w(i), i=1,2,...,m,subroutine concon determines a cubic spline
-c approximation s(x) which satisfies the following local convexity
-c constraints s''(x(i))*v(i) <= 0, i=1,2,...,m.
-c the number of knots n and the position t(j),j=1,2,...n is chosen
-c automatically by the routine in a way that
-c sq = sum((w(i)*(y(i)-s(x(i))))**2) be <= s.
-c the fit is given in the b-spline representation (b-spline coef-
-c ficients c(j),j=1,2,...n-4) and can be evaluated by means of
-c subroutine splev.
-c
-c calling sequence:
-c
-c call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,
-c * sx,bind,wrk,lwrk,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt: integer flag.
-c if iopt=0, the routine will start with the minimal number of
-c knots to guarantee that the convexity conditions will be
-c satisfied. if iopt=1, the routine will continue with the set
-c of knots found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m > 3. unchanged on exit.
-c x : real array of dimension at least (m). before entry, x(i)
-c must be set to the i-th value of the independent variable x,
-c for i=1,2,...,m. these values must be supplied in strictly
-c ascending order. unchanged on exit.
-c y : real array of dimension at least (m). before entry, y(i)
-c must be set to the i-th value of the dependent variable y,
-c for i=1,2,...,m. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. unchanged on exit.
-c v : real array of dimension at least (m). before entry, v(i)
-c must be set to 1 if s(x) must be locally concave at x(i),
-c to (-1) if s(x) must be locally convex at x(i) and to 0
-c if no convexity constraint is imposed at x(i).
-c s : real. on entry s must specify an over-estimate for the
-c the weighted sum of squared residuals sq of the requested
-c spline. s >=0. unchanged on exit.
-c nest : integer. on entry nest must contain an over-estimate of the
-c total number of knots of the spline returned, to indicate
-c the storage space available to the routine. nest >=8.
-c in most practical situation nest=m/2 will be sufficient.
-c always large enough is nest=m+4. unchanged on exit.
-c maxtr : integer. on entry maxtr must contain an over-estimate of the
-c total number of records in the used tree structure, to indic-
-c ate the storage space available to the routine. maxtr >=1
-c in most practical situation maxtr=100 will be sufficient.
-c always large enough is
-c nest-5 nest-6
-c maxtr = ( ) + ( ) with l the greatest
-c l l+1
-c integer <= (nest-6)/2 . unchanged on exit.
-c maxbin: integer. on entry maxbin must contain an over-estimate of the
-c number of knots where s(x) will have a zero second derivative
-c maxbin >=1. in most practical situation maxbin = 10 will be
-c sufficient. always large enough is maxbin=nest-6.
-c unchanged on exit.
-c n : integer.
-c on exit with ier <=0, n will contain the total number of
-c knots of the spline approximation returned. if the comput-
-c ation mode iopt=1 is used this value of n should be left
-c unchanged between subsequent calls.
-c t : real array of dimension at least (nest).
-c on exit with ier<=0, this array will contain the knots of the
-c spline,i.e. the position of the interior knots t(5),t(6),...,
-c t(n-4) as well as the position of the additional knots
-c t(1)=t(2)=t(3)=t(4)=x(1) and t(n-3)=t(n-2)=t(n-1)=t(n)=x(m)
-c needed for the the b-spline representation.
-c if the computation mode iopt=1 is used, the values of t(1),
-c t(2),...,t(n) should be left unchanged between subsequent
-c calls.
-c c : real array of dimension at least (nest).
-c on succesful exit, this array will contain the coefficients
-c c(1),c(2),..,c(n-4) in the b-spline representation of s(x)
-c sq : real. unless ier>0 , sq contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c sx : real array of dimension at least m. on exit with ier<=0
-c this array will contain the spline values s(x(i)),i=1,...,m
-c if the computation mode iopt=1 is used, the values of sx(1),
-c sx(2),...,sx(m) should be left unchanged between subsequent
-c calls.
-c bind: logical array of dimension at least nest. on exit with ier<=0
-c this array will indicate the knots where s''(x)=0, i.e.
-c s''(t(j+3)) .eq. 0 if bind(j) = .true.
-c s''(t(j+3)) .ne. 0 if bind(j) = .false., j=1,2,...,n-6
-c if the computation mode iopt=1 is used, the values of bind(1)
-c ,...,bind(n-6) should be left unchanged between subsequent
-c calls.
-c wrk : real array of dimension at least (m*4+nest*8+maxbin*(maxbin+
-c nest+1)). used as working space.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1))
-c used as working space.
-c kwrk : integer. on entry,kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program. kwrk
-c must not be too small (see iwrk). unchanged on exit.
-c ier : integer. error flag
-c ier=0 : normal return, s(x) satisfies the concavity/convexity
-c constraints and sq <= s.
-c ier<0 : abnormal termination: s(x) satisfies the concavity/
-c convexity constraints but sq > s.
-c ier=-3 : the requested storage space exceeds the available
-c storage space as specified by the parameter nest.
-c probably causes: nest too small. if nest is already
-c large (say nest > m/2), it may also indicate that s
-c is too small.
-c the approximation returned is the least-squares cubic
-c spline according to the knots t(1),...,t(n) (n=nest)
-c which satisfies the convexity constraints.
-c ier=-2 : the maximal number of knots n=m+4 has been reached.
-c probably causes: s too small.
-c ier=-1 : the number of knots n is less than the maximal number
-c m+4 but concon finds that adding one or more knots
-c will not further reduce the value of sq.
-c probably causes : s too small.
-c ier>0 : abnormal termination: no approximation is returned
-c ier=1 : the number of knots where s''(x)=0 exceeds maxbin.
-c probably causes : maxbin too small.
-c ier=2 : the number of records in the tree structure exceeds
-c maxtr.
-c probably causes : maxtr too small.
-c ier=3 : the algoritm finds no solution to the posed quadratic
-c programming problem.
-c probably causes : rounding errors.
-c ier=4 : the minimum number of knots (given by n) to guarantee
-c that the concavity/convexity conditions will be
-c satisfied is greater than nest.
-c probably causes: nest too small.
-c ier=5 : the minimum number of knots (given by n) to guarantee
-c that the concavity/convexity conditions will be
-c satisfied is greater than m+4.
-c probably causes: strongly alternating convexity and
-c concavity conditions. normally the situation can be
-c coped with by adding n-m-4 extra data points (found
-c by linear interpolation e.g.) with a small weight w(i)
-c and a v(i) number equal to zero.
-c ier=10 : on entry, the input data are controlled on validity.
-c the following restrictions must be satisfied
-c 0<=iopt<=1, m>3, nest>=8, s>=0, maxtr>=1, maxbin>=1,
-c kwrk>=maxtr*4+2*(maxbin+1), w(i)>0, x(i) < x(i+1),
-c lwrk>=m*4+nest*8+maxbin*(maxbin+nest+1)
-c if one of these restrictions is found to be violated
-c control is immediately repassed to the calling program
-c
-c further comments:
-c as an example of the use of the computation mode iopt=1, the
-c following program segment will cause concon to return control
-c each time a spline with a new set of knots has been computed.
-c .............
-c iopt = 0
-c s = 0.1e+60 (s very large)
-c do 10 i=1,m
-c call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx,
-c * bind,wrk,lwrk,iwrk,kwrk,ier)
-c ......
-c s = sq
-c iopt=1
-c 10 continue
-c .............
-c
-c other subroutines required:
-c fpcoco,fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno
-c
-c references:
-c dierckx p. : an algorithm for cubic spline fitting with convexity
-c constraints, computing 24 (1980) 349-371.
-c dierckx p. : an algorithm for least-squares cubic spline fitting
-c with convexity and concavity constraints, report tw39,
-c dept. computer science, k.u.leuven, 1978.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p. dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : march 1978
-c latest update : march 1987.
-c
-c ..
-c ..scalar arguments..
- real*8 s,sq
- integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),wrk(lwrk)
- integer iwrk(kwrk)
- logical bind(nest)
-c ..local scalars..
- integer i,lwest,kwest,ie,iw,lww
- real*8 one
-c ..
-c set constant
- one = 0.1e+01
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt.lt.0 .or. iopt.gt.1) go to 30
- if(m.lt.4 .or. nest.lt.8) go to 30
- if(s.lt.0.) go to 30
- if(maxtr.lt.1 .or. maxbin.lt.1) go to 30
- lwest = 8*nest+m*4+maxbin*(1+nest+maxbin)
- kwest = 4*maxtr+2*(maxbin+1)
- if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 30
- if(iopt.gt.0) go to 20
- if(w(1).le.0.) go to 30
- if(v(1).gt.0.) v(1) = one
- if(v(1).lt.0.) v(1) = -one
- do 10 i=2,m
- if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 30
- if(v(i).gt.0.) v(i) = one
- if(v(i).lt.0.) v(i) = -one
- 10 continue
- 20 ier = 0
-c we partition the working space and determine the spline approximation
- ie = 1
- iw = ie+nest
- lww = lwrk-nest
- call fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx,
- * bind,wrk(ie),wrk(iw),lww,iwrk,kwrk,ier)
- 30 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/concur.f
===================================================================
--- branches/Interpolate1D/fitpack/concur.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/concur.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,370 +0,0 @@
- subroutine concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,
- * nest,n,t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier)
-c given the ordered set of m points x(i) in the idim-dimensional space
-c and given also a corresponding set of strictly increasing values u(i)
-c and the set of positive numbers w(i),i=1,2,...,m, subroutine concur
-c determines a smooth approximating spline curve s(u), i.e.
-c x1 = s1(u)
-c x2 = s2(u) ub = u(1) <= u <= u(m) = ue
-c .........
-c xidim = sidim(u)
-c with sj(u),j=1,2,...,idim spline functions of odd degree k with
-c common knots t(j),j=1,2,...,n.
-c in addition these splines will satisfy the following boundary
-c constraints (l)
-c if ib > 0 : sj (u(1)) = db(idim*l+j) ,l=0,1,...,ib-1
-c and (l)
-c if ie > 0 : sj (u(m)) = de(idim*l+j) ,l=0,1,...,ie-1.
-c if iopt=-1 concur calculates the weighted least-squares spline curve
-c according to a given set of knots.
-c if iopt>=0 the number of knots of the splines sj(u) and the position
-c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
-c ness of s(u) is then achieved by minimalizing the discontinuity
-c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,...,
-c n-k-1. the amount of smoothness is determined by the condition that
-c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non-
-c negative constant, called the smoothing factor.
-c the fit s(u) is given in the b-spline representation and can be
-c evaluated by means of subroutine curev.
-c
-c calling sequence:
-c call concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,nest,n,
-c * t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares spline curve (iopt=-1) or a smoothing spline
-c curve (iopt=0 or 1) must be determined.if iopt=0 the routine
-c will start with an initial set of knots t(i)=ub,t(i+k+1)=ue,
-c i=1,2,...,k+1. if iopt=1 the routine will continue with the
-c knots found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c idim : integer. on entry idim must specify the dimension of the
-c curve. 0 < idim < 11.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m > k-max(ib-1,0)-max(ie-1,0). unchanged on exit.
-c u : real array of dimension at least (m). before entry,
-c u(i) must be set to the i-th value of the parameter variable
-c u for i=1,2,...,m. these values must be supplied in
-c strictly ascending order and will be unchanged on exit.
-c mx : integer. on entry mx must specify the actual dimension of
-c the arrays x and xx as declared in the calling (sub)program
-c mx must not be too small (see x). unchanged on exit.
-c x : real array of dimension at least idim*m.
-c before entry, x(idim*(i-1)+j) must contain the j-th coord-
-c inate of the i-th data point for i=1,2,...,m and j=1,2,...,
-c idim. unchanged on exit.
-c xx : real array of dimension at least idim*m.
-c used as working space. on exit xx contains the coordinates
-c of the data points to which a spline curve with zero deriv-
-c ative constraints has been determined.
-c if the computation mode iopt =1 is used xx should be left
-c unchanged between calls.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. unchanged on exit.
-c see also further comments.
-c ib : integer. on entry ib must specify the number of derivative
-c constraints for the curve at the begin point. 0<=ib<=(k+1)/2
-c unchanged on exit.
-c db : real array of dimension nb. before entry db(idim*l+j) must
-c contain the l-th order derivative of sj(u) at u=u(1) for
-c j=1,2,...,idim and l=0,1,...,ib-1 (if ib>0).
-c unchanged on exit.
-c nb : integer, specifying the dimension of db. nb>=max(1,idim*ib)
-c unchanged on exit.
-c ie : integer. on entry ie must specify the number of derivative
-c constraints for the curve at the end point. 0<=ie<=(k+1)/2
-c unchanged on exit.
-c de : real array of dimension ne. before entry de(idim*l+j) must
-c contain the l-th order derivative of sj(u) at u=u(m) for
-c j=1,2,...,idim and l=0,1,...,ie-1 (if ie>0).
-c unchanged on exit.
-c ne : integer, specifying the dimension of de. ne>=max(1,idim*ie)
-c unchanged on exit.
-c k : integer. on entry k must specify the degree of the splines.
-c k=1,3 or 5.
-c unchanged on exit.
-c s : real.on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments.
-c nest : integer. on entry nest must contain an over-estimate of the
-c total number of knots of the splines returned, to indicate
-c the storage space available to the routine. nest >=2*k+2.
-c in most practical situation nest=m/2 will be sufficient.
-c always large enough is nest=m+k+1+max(0,ib-1)+max(0,ie-1),
-c the number of knots needed for interpolation (s=0).
-c unchanged on exit.
-c n : integer.
-c unless ier = 10 (in case iopt >=0), n will contain the
-c total number of knots of the smoothing spline curve returned
-c if the computation mode iopt=1 is used this value of n
-c should be left unchanged between subsequent calls.
-c in case iopt=-1, the value of n must be specified on entry.
-c t : real array of dimension at least (nest).
-c on succesful exit, this array will contain the knots of the
-c spline curve,i.e. the position of the interior knots t(k+2),
-c t(k+3),..,t(n-k-1) as well as the position of the additional
-c t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for
-c the b-spline representation.
-c if the computation mode iopt=1 is used, the values of t(1),
-c t(2),...,t(n) should be left unchanged between subsequent
-c calls. if the computation mode iopt=-1 is used, the values
-c t(k+2),...,t(n-k-1) must be supplied by the user, before
-c entry. see also the restrictions (ier=10).
-c nc : integer. on entry nc must specify the actual dimension of
-c the array c as declared in the calling (sub)program. nc
-c must not be too small (see c). unchanged on exit.
-c c : real array of dimension at least (nest*idim).
-c on succesful exit, this array will contain the coefficients
-c in the b-spline representation of the spline curve s(u),i.e.
-c the b-spline coefficients of the spline sj(u) will be given
-c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim.
-c cp : real array of dimension at least 2*(k+1)*idim.
-c on exit cp will contain the b-spline coefficients of a
-c polynomial curve which satisfies the boundary constraints.
-c if the computation mode iopt =1 is used cp should be left
-c unchanged between calls.
-c np : integer. on entry np must specify the actual dimension of
-c the array cp as declared in the calling (sub)program. np
-c must not be too small (see cp). unchanged on exit.
-c fp : real. unless ier = 10, fp contains the weighted sum of
-c squared residuals of the spline curve returned.
-c wrk : real array of dimension at least m*(k+1)+nest*(6+idim+3*k).
-c used as working space. if the computation mode iopt=1 is
-c used, the values wrk(1),...,wrk(n) should be left unchanged
-c between subsequent calls.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program. lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (nest).
-c used as working space. if the computation mode iopt=1 is
-c used,the values iwrk(1),...,iwrk(n) should be left unchanged
-c between subsequent calls.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the curve returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the curve returned is an interpolating
-c spline curve, satisfying the constraints (fp=0).
-c ier=-2 : normal return. the curve returned is the weighted least-
-c squares polynomial curve of degree k, satisfying the
-c constraints. in this extreme case fp gives the upper
-c bound fp0 for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameter nest.
-c probably causes : nest too small. if nest is already
-c large (say nest > m/2), it may also indicate that s is
-c too small
-c the approximation returned is the least-squares spline
-c curve according to the knots t(1),t(2),...,t(n). (n=nest)
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline curve
-c with fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing curve
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, k = 1,3 or 5, m>k-max(0,ib-1)-max(0,ie-1),
-c nest>=2k+2, 0<idim<=10, lwrk>=(k+1)*m+nest*(6+idim+3*k),
-c nc >=nest*idim ,u(1)<u(2)<...<u(m),w(i)>0 i=1,2,...,m,
-c mx>=idim*m,0<=ib<=(k+1)/2,0<=ie<=(k+1)/2,nb>=1,ne>=1,
-c nb>=ib*idim,ne>=ib*idim,np>=2*(k+1)*idim,
-c if iopt=-1:2*k+2<=n<=min(nest,mmax) with mmax = m+k+1+
-c max(0,ib-1)+max(0,ie-1)
-c u(1)<t(k+2)<t(k+3)<...<t(n-k-1)<u(m)
-c the schoenberg-whitney conditions, i.e. there
-c must be a subset of data points uu(j) such that
-c t(j) < uu(j) < t(j+k+1), j=1+max(0,ib-1),...
-c ,n+k-1-max(0,ie-1)
-c if iopt>=0: s>=0
-c if s=0 : nest >=mmax (see above)
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the curve will be too smooth and signal will be
-c lost ; if s is too small the curve will pick up too much noise. in
-c the extreme cases the program will return an interpolating curve if
-c s=0 and the least-squares polynomial curve of degree k if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in x(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c polynomial curve and the upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximating curve shows more detail) to obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if concur is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c curve underlying the data. but, if the computation mode iopt=1 is
-c used, the knots returned may also depend on the s-values at previous
-c calls (if these were smaller). therefore, if after a number of
-c trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c concur once more with the selected value for s but now with iopt=0.
-c indeed, concur may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c
-c the form of the approximating curve can strongly be affected by
-c the choice of the parameter values u(i). if there is no physical
-c reason for choosing a particular parameter u, often good results
-c will be obtained with the choice
-c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m
-c where
-c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 )
-c other possibilities for q(i) are
-c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2
-c q(i)= sum j=1,idim abs(xj(i)-xj(i-1))
-c q(i)= max j=1,idim abs(xj(i)-xj(i-1))
-c q(i)= 1
-c
-c other subroutines required:
-c fpback,fpbspl,fpched,fpcons,fpdisc,fpgivs,fpknot,fprati,fprota
-c curev,fppocu,fpadpo,fpinst
-c
-c references:
-c dierckx p. : algorithms for smoothing data with periodic and
-c parametric splines, computer graphics and image
-c processing 20 (1982) 171-184.
-c dierckx p. : algorithms for smoothing data with periodic and param-
-c etric splines, report tw55, dept. computer science,
-c k.u.leuven, 1981.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- real*8 s,fp
- integer iopt,idim,m,mx,ib,nb,ie,ne,k,nest,n,nc,np,lwrk,ier
-c ..array arguments..
- real*8 u(m),x(mx),xx(mx),db(nb),de(ne),w(m),t(nest),c(nc),wrk(lwrk
- *)
- real*8 cp(np)
- integer iwrk(nest)
-c ..local scalars..
- real*8 tol,dist
- integer i,ib1,ie1,ja,jb,jfp,jg,jq,jz,j,k1,k2,lwest,maxit,nmin,
- * ncc,kk,mmin,nmax,mxx
-c ..function references
- integer max0
-c ..
-c we set up the parameters tol and maxit
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 90
- if(idim.le.0 .or. idim.gt.10) go to 90
- if(k.le.0 .or. k.gt.5) go to 90
- k1 = k+1
- kk = k1/2
- if(kk*2.ne.k1) go to 90
- k2 = k1+1
- if(ib.lt.0 .or. ib.gt.kk) go to 90
- if(ie.lt.0 .or. ie.gt.kk) go to 90
- nmin = 2*k1
- ib1 = max0(0,ib-1)
- ie1 = max0(0,ie-1)
- mmin = k1-ib1-ie1
- if(m.lt.mmin .or. nest.lt.nmin) go to 90
- if(nb.lt.(idim*ib) .or. ne.lt.(idim*ie)) go to 90
- if(np.lt.(2*k1*idim)) go to 90
- mxx = m*idim
- ncc = nest*idim
- if(mx.lt.mxx .or. nc.lt.ncc) go to 90
- lwest = m*k1+nest*(6+idim+3*k)
- if(lwrk.lt.lwest) go to 90
- if(w(1).le.0.) go to 90
- do 10 i=2,m
- if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90
- 10 continue
- if(iopt.ge.0) go to 30
- if(n.lt.nmin .or. n.gt.nest) go to 90
- j = n
- do 20 i=1,k1
- t(i) = u(1)
- t(j) = u(m)
- j = j-1
- 20 continue
- call fpched(u,m,t,n,k,ib,ie,ier)
- if (ier.eq.0) go to 40
- go to 90
- 30 if(s.lt.0.) go to 90
- nmax = m+k1+ib1+ie1
- if(s.eq.0. .and. nest.lt.nmax) go to 90
- ier = 0
- if(iopt.gt.0) go to 70
-c we determine a polynomial curve satisfying the boundary constraints.
- 40 call fppocu(idim,k,u(1),u(m),ib,db,nb,ie,de,ne,cp,np)
-c we generate new data points which will be approximated by a spline
-c with zero derivative constraints.
- j = nmin
- do 50 i=1,k1
- wrk(i) = u(1)
- wrk(j) = u(m)
- j = j-1
- 50 continue
-c evaluate the polynomial curve
- call curev(idim,wrk,nmin,cp,np,k,u,m,xx,mxx,ier)
-c substract from the old data, the values of the polynomial curve
- do 60 i=1,mxx
- xx(i) = x(i)-xx(i)
- 60 continue
-c we partition the working space and determine the spline curve.
- 70 jfp = 1
- jz = jfp+nest
- ja = jz+ncc
- jb = ja+nest*k1
- jg = jb+nest*k2
- jq = jg+nest*k2
- call fpcons(iopt,idim,m,u,mxx,xx,w,ib,ie,k,s,nest,tol,maxit,k1,
- * k2,n,t,ncc,c,fp,wrk(jfp),wrk(jz),wrk(ja),wrk(jb),wrk(jg),wrk(jq),
- *
- * iwrk,ier)
-c add the polynomial curve to the calculated spline.
- call fpadpo(idim,t,n,c,ncc,k,cp,np,wrk(jz),wrk(ja),wrk(jb))
- 90 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/cualde.f
===================================================================
--- branches/Interpolate1D/fitpack/cualde.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/cualde.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,91 +0,0 @@
- subroutine cualde(idim,t,n,c,nc,k1,u,d,nd,ier)
-c subroutine cualde evaluates at the point u all the derivatives
-c (l)
-c d(idim*l+j) = sj (u) ,l=0,1,...,k, j=1,2,...,idim
-c of a spline curve s(u) of order k1 (degree k=k1-1) and dimension idim
-c given in its b-spline representation.
-c
-c calling sequence:
-c call cualde(idim,t,n,c,nc,k1,u,d,nd,ier)
-c
-c input parameters:
-c idim : integer, giving the dimension of the spline curve.
-c t : array,length n, which contains the position of the knots.
-c n : integer, giving the total number of knots of s(u).
-c c : array,length nc, which contains the b-spline coefficients.
-c nc : integer, giving the total number of coefficients of s(u).
-c k1 : integer, giving the order of s(u) (order=degree+1).
-c u : real, which contains the point where the derivatives must
-c be evaluated.
-c nd : integer, giving the dimension of the array d. nd >= k1*idim
-c
-c output parameters:
-c d : array,length nd,giving the different curve derivatives.
-c d(idim*l+j) will contain the j-th coordinate of the l-th
-c derivative of the curve at the point u.
-c ier : error flag
-c ier = 0 : normal return
-c ier =10 : invalid input data (see restrictions)
-c
-c restrictions:
-c nd >= k1*idim
-c t(k1) <= u <= t(n-k1+1)
-c
-c further comments:
-c if u coincides with a knot, right derivatives are computed
-c ( left derivatives if u = t(n-k1+1) ).
-c
-c other subroutines required: fpader.
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer idim,n,nc,k1,nd,ier
- real*8 u
-c ..array arguments..
- real*8 t(n),c(nc),d(nd)
-c ..local scalars..
- integer i,j,kk,l,m,nk1
-c ..local array..
- real*8 h(6)
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- if(nd.lt.(k1*idim)) go to 500
- nk1 = n-k1
- if(u.lt.t(k1) .or. u.gt.t(nk1+1)) go to 500
-c search for knot interval t(l) <= u < t(l+1)
- l = k1
- 100 if(u.lt.t(l+1) .or. l.eq.nk1) go to 200
- l = l+1
- go to 100
- 200 if(t(l).ge.t(l+1)) go to 500
- ier = 0
-c calculate the derivatives.
- j = 1
- do 400 i=1,idim
- call fpader(t,n,c(j),k1,u,l,h)
- m = i
- do 300 kk=1,k1
- d(m) = h(kk)
- m = m+idim
- 300 continue
- j = j+n
- 400 continue
- 500 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/curev.f
===================================================================
--- branches/Interpolate1D/fitpack/curev.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/curev.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,110 +0,0 @@
- subroutine curev(idim,t,n,c,nc,k,u,m,x,mx,ier)
-c subroutine curev evaluates in a number of points u(i),i=1,2,...,m
-c a spline curve s(u) of degree k and dimension idim, given in its
-c b-spline representation.
-c
-c calling sequence:
-c call curev(idim,t,n,c,nc,k,u,m,x,mx,ier)
-c
-c input parameters:
-c idim : integer, giving the dimension of the spline curve.
-c t : array,length n, which contains the position of the knots.
-c n : integer, giving the total number of knots of s(u).
-c c : array,length nc, which contains the b-spline coefficients.
-c nc : integer, giving the total number of coefficients of s(u).
-c k : integer, giving the degree of s(u).
-c u : array,length m, which contains the points where s(u) must
-c be evaluated.
-c m : integer, giving the number of points where s(u) must be
-c evaluated.
-c mx : integer, giving the dimension of the array x. mx >= m*idim
-c
-c output parameters:
-c x : array,length mx,giving the value of s(u) at the different
-c points. x(idim*(i-1)+j) will contain the j-th coordinate
-c of the i-th point on the curve.
-c ier : error flag
-c ier = 0 : normal return
-c ier =10 : invalid input data (see restrictions)
-c
-c restrictions:
-c m >= 1
-c mx >= m*idim
-c t(k+1) <= u(i) <= u(i+1) <= t(n-k) , i=1,2,...,m-1.
-c
-c other subroutines required: fpbspl.
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer idim,n,nc,k,m,mx,ier
-c ..array arguments..
- real*8 t(n),c(nc),u(m),x(mx)
-c ..local scalars..
- integer i,j,jj,j1,k1,l,ll,l1,mm,nk1
- real*8 arg,sp,tb,te
-c ..local array..
- real*8 h(6)
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- if (m.lt.1) go to 100
- if (m.eq.1) go to 30
- go to 10
- 10 do 20 i=2,m
- if(u(i).lt.u(i-1)) go to 100
- 20 continue
- 30 if(mx.lt.(m*idim)) go to 100
- ier = 0
-c fetch tb and te, the boundaries of the approximation interval.
- k1 = k+1
- nk1 = n-k1
- tb = t(k1)
- te = t(nk1+1)
- l = k1
- l1 = l+1
-c main loop for the different points.
- mm = 0
- do 80 i=1,m
-c fetch a new u-value arg.
- arg = u(i)
- if(arg.lt.tb) arg = tb
- if(arg.gt.te) arg = te
-c search for knot interval t(l) <= arg < t(l+1)
- 40 if(arg.lt.t(l1) .or. l.eq.nk1) go to 50
- l = l1
- l1 = l+1
- go to 40
-c evaluate the non-zero b-splines at arg.
- 50 call fpbspl(t,n,k,arg,l,h)
-c find the value of s(u) at u=arg.
- ll = l-k1
- do 70 j1=1,idim
- jj = ll
- sp = 0.
- do 60 j=1,k1
- jj = jj+1
- sp = sp+c(jj)*h(j)
- 60 continue
- mm = mm+1
- x(mm) = sp
- ll = ll+n
- 70 continue
- 80 continue
- 100 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/curfit.f
===================================================================
--- branches/Interpolate1D/fitpack/curfit.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/curfit.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,261 +0,0 @@
- subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,
- * wrk,lwrk,iwrk,ier)
-c given the set of data points (x(i),y(i)) and the set of positive
-c numbers w(i),i=1,2,...,m,subroutine curfit determines a smooth spline
-c approximation of degree k on the interval xb <= x <= xe.
-c if iopt=-1 curfit calculates the weighted least-squares spline
-c according to a given set of knots.
-c if iopt>=0 the number of knots of the spline s(x) and the position
-c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
-c ness of s(x) is then achieved by minimalizing the discontinuity
-c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,...,
-c n-k-1. the amount of smoothness is determined by the condition that
-c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non-
-c negative constant, called the smoothing factor.
-c the fit s(x) is given in the b-spline representation (b-spline coef-
-c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of
-c subroutine splev.
-c
-c calling sequence:
-c call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk,
-c * lwrk,iwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares spline (iopt=-1) or a smoothing spline (iopt=
-c 0 or 1) must be determined. if iopt=0 the routine will start
-c with an initial set of knots t(i)=xb, t(i+k+1)=xe, i=1,2,...
-c k+1. if iopt=1 the routine will continue with the knots
-c found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m > k. unchanged on exit.
-c x : real array of dimension at least (m). before entry, x(i)
-c must be set to the i-th value of the independent variable x,
-c for i=1,2,...,m. these values must be supplied in strictly
-c ascending order. unchanged on exit.
-c y : real array of dimension at least (m). before entry, y(i)
-c must be set to the i-th value of the dependent variable y,
-c for i=1,2,...,m. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. unchanged on exit.
-c see also further comments.
-c xb,xe : real values. on entry xb and xe must specify the boundaries
-c of the approximation interval. xb<=x(1), xe>=x(m).
-c unchanged on exit.
-c k : integer. on entry k must specify the degree of the spline.
-c 1<=k<=5. it is recommended to use cubic splines (k=3).
-c the user is strongly dissuaded from choosing k even,together
-c with a small s-value. unchanged on exit.
-c s : real.on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments.
-c nest : integer. on entry nest must contain an over-estimate of the
-c total number of knots of the spline returned, to indicate
-c the storage space available to the routine. nest >=2*k+2.
-c in most practical situation nest=m/2 will be sufficient.
-c always large enough is nest=m+k+1, the number of knots
-c needed for interpolation (s=0). unchanged on exit.
-c n : integer.
-c unless ier =10 (in case iopt >=0), n will contain the
-c total number of knots of the spline approximation returned.
-c if the computation mode iopt=1 is used this value of n
-c should be left unchanged between subsequent calls.
-c in case iopt=-1, the value of n must be specified on entry.
-c t : real array of dimension at least (nest).
-c on succesful exit, this array will contain the knots of the
-c spline,i.e. the position of the interior knots t(k+2),t(k+3)
-c ...,t(n-k-1) as well as the position of the additional knots
-c t(1)=t(2)=...=t(k+1)=xb and t(n-k)=...=t(n)=xe needed for
-c the b-spline representation.
-c if the computation mode iopt=1 is used, the values of t(1),
-c t(2),...,t(n) should be left unchanged between subsequent
-c calls. if the computation mode iopt=-1 is used, the values
-c t(k+2),...,t(n-k-1) must be supplied by the user, before
-c entry. see also the restrictions (ier=10).
-c c : real array of dimension at least (nest).
-c on succesful exit, this array will contain the coefficients
-c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x)
-c fp : real. unless ier=10, fp contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c wrk : real array of dimension at least (m*(k+1)+nest*(7+3*k)).
-c used as working space. if the computation mode iopt=1 is
-c used, the values wrk(1),...,wrk(n) should be left unchanged
-c between subsequent calls.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (nest).
-c used as working space. if the computation mode iopt=1 is
-c used,the values iwrk(1),...,iwrk(n) should be left unchanged
-c between subsequent calls.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c spline (fp=0).
-c ier=-2 : normal return. the spline returned is the weighted least-
-c squares polynomial of degree k. in this extreme case fp
-c gives the upper bound fp0 for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameter nest.
-c probably causes : nest too small. if nest is already
-c large (say nest > m/2), it may also indicate that s is
-c too small
-c the approximation returned is the weighted least-squares
-c spline according to the knots t(1),t(2),...,t(n). (n=nest)
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m
-c xb<=x(1)<x(2)<...<x(m)<=xe, lwrk>=(k+1)*m+nest*(7+3*k)
-c if iopt=-1: 2*k+2<=n<=min(nest,m+k+1)
-c xb<t(k+2)<t(k+3)<...<t(n-k-1)<xe
-c the schoenberg-whitney conditions, i.e. there
-c must be a subset of data points xx(j) such that
-c t(j) < xx(j) < t(j+k+1), j=1,2,...,n-k-1
-c if iopt>=0: s>=0
-c if s=0 : nest >= m+k+1
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the weighted least-squares polynomial of degree k if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in y(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c polynomial and the corresponding upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximation shows more detail) to obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if curfit is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. but, if the computation mode iopt=1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c curfit once more with the selected value for s but now with iopt=0.
-c indeed, curfit may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c
-c other subroutines required:
-c fpback,fpbspl,fpchec,fpcurf,fpdisc,fpgivs,fpknot,fprati,fprota
-c
-c references:
-c dierckx p. : an algorithm for smoothing, differentiation and integ-
-c ration of experimental data using spline functions,
-c j.comp.appl.maths 1 (1975) 165-184.
-c dierckx p. : a fast algorithm for smoothing data on a rectangular
-c grid while using spline functions, siam j.numer.anal.
-c 19 (1982) 1286-1304.
-c dierckx p. : an improved algorithm for curve fitting with spline
-c functions, report tw54, dept. computer science,k.u.
-c leuven, 1981.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- real*8 xb,xe,s,fp
- integer iopt,m,k,nest,n,lwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk)
- integer iwrk(nest)
-c ..local scalars..
- real*8 tol
- integer i,ia,ib,ifp,ig,iq,iz,j,k1,k2,lwest,maxit,nmin
-c ..
-c we set up the parameters tol and maxit
- maxit = 20
- tol = 0.1d-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(k.le.0 .or. k.gt.5) go to 50
- k1 = k+1
- k2 = k1+1
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 50
- nmin = 2*k1
- if(m.lt.k1 .or. nest.lt.nmin) go to 50
- lwest = m*k1+nest*(7+3*k)
- if(lwrk.lt.lwest) go to 50
- if(xb.gt.x(1) .or. xe.lt.x(m) .or. w(1).le.0.) go to 50
- do 10 i=2,m
- if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 50
- 10 continue
- if(iopt.ge.0) go to 30
- if(n.lt.nmin .or. n.gt.nest) go to 50
- j = n
- do 20 i=1,k1
- t(i) = xb
- t(j) = xe
- j = j-1
- 20 continue
- call fpchec(x,m,t,n,k,ier)
- if (ier.eq.0) go to 40
- go to 50
- 30 if(s.lt.0.) go to 50
- if(s.eq.0. .and. nest.lt.(m+k1)) go to 50
- ier = 0
-c we partition the working space and determine the spline approximation.
- 40 ifp = 1
- iz = ifp+nest
- ia = iz+nest
- ib = ia+nest*k1
- ig = ib+nest*k2
- iq = ig+nest*k2
- call fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp,
- * wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq),iwrk,ier)
- 50 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/dblint.f
===================================================================
--- branches/Interpolate1D/fitpack/dblint.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/dblint.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,88 +0,0 @@
- real*8 function dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk)
-c function dblint calculates the double integral
-c / xe / ye
-c | | s(x,y) dx dy
-c xb / yb /
-c with s(x,y) a bivariate spline of degrees kx and ky, given in the
-c b-spline representation.
-c
-c calling sequence:
-c aint = dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk)
-c
-c input parameters:
-c tx : real array, length nx, which contains the position of the
-c knots in the x-direction.
-c nx : integer, giving the total number of knots in the x-direction
-c ty : real array, length ny, which contains the position of the
-c knots in the y-direction.
-c ny : integer, giving the total number of knots in the y-direction
-c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the
-c b-spline coefficients.
-c kx,ky : integer values, giving the degrees of the spline.
-c xb,xe : real values, containing the boundaries of the integration
-c yb,ye domain. s(x,y) is considered to be identically zero out-
-c side the rectangle (tx(kx+1),tx(nx-kx))*(ty(ky+1),ty(ny-ky))
-c
-c output parameters:
-c aint : real , containing the double integral of s(x,y).
-c wrk : real array of dimension at least (nx+ny-kx-ky-2).
-c used as working space.
-c on exit, wrk(i) will contain the integral
-c / xe
-c | ni,kx+1(x) dx , i=1,2,...,nx-kx-1
-c xb /
-c with ni,kx+1(x) the normalized b-spline defined on
-c the knots tx(i),...,tx(i+kx+1)
-c wrk(j+nx-kx-1) will contain the integral
-c / ye
-c | nj,ky+1(y) dy , j=1,2,...,ny-ky-1
-c yb /
-c with nj,ky+1(y) the normalized b-spline defined on
-c the knots ty(j),...,ty(j+ky+1)
-c
-c other subroutines required: fpintb
-c
-c references :
-c gaffney p.w. : the calculation of indefinite integrals of b-splines
-c j. inst. maths applics 17 (1976) 37-41.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1989
-c
-c ..scalar arguments..
- integer nx,ny,kx,ky
- real*8 xb,xe,yb,ye
-c ..array arguments..
- real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),wrk(nx+ny-kx-ky-2)
-c ..local scalars..
- integer i,j,l,m,nkx1,nky1
- real*8 res
-c ..
- nkx1 = nx-kx-1
- nky1 = ny-ky-1
-c we calculate the integrals of the normalized b-splines ni,kx+1(x)
- call fpintb(tx,nx,wrk,nkx1,xb,xe)
-c we calculate the integrals of the normalized b-splines nj,ky+1(y)
- call fpintb(ty,ny,wrk(nkx1+1),nky1,yb,ye)
-c calculate the integral of s(x,y)
- dblint = 0.
- do 200 i=1,nkx1
- res = wrk(i)
- if(res.eq.0.) go to 200
- m = (i-1)*nky1
- l = nkx1
- do 100 j=1,nky1
- m = m+1
- l = l+1
- dblint = dblint+res*wrk(l)*c(m)
- 100 continue
- 200 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/evapol.f
===================================================================
--- branches/Interpolate1D/fitpack/evapol.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/evapol.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,82 +0,0 @@
- real*8 function evapol(tu,nu,tv,nv,c,rad,x,y)
-c function program evacir evaluates the function f(x,y) = s(u,v),
-c defined through the transformation
-c x = u*rad(v)*cos(v) y = u*rad(v)*sin(v)
-c and where s(u,v) is a bicubic spline ( 0<=u<=1 , -pi<=v<=pi ), given
-c in its standard b-spline representation.
-c
-c calling sequence:
-c f = evapol(tu,nu,tv,nv,c,rad,x,y)
-c
-c input parameters:
-c tu : real array, length nu, which contains the position of the
-c knots in the u-direction.
-c nu : integer, giving the total number of knots in the u-direction
-c tv : real array, length nv, which contains the position of the
-c knots in the v-direction.
-c nv : integer, giving the total number of knots in the v-direction
-c c : real array, length (nu-4)*(nv-4), which contains the
-c b-spline coefficients.
-c rad : real function subprogram, defining the boundary of the
-c approximation domain. must be declared external in the
-c calling (sub)-program
-c x,y : real values.
-c before entry x and y must be set to the co-ordinates of
-c the point where f(x,y) must be evaluated.
-c
-c output parameter:
-c f : real
-c on exit f contains the value of f(x,y)
-c
-c other subroutines required:
-c bispev,fpbisp,fpbspl
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1989
-c
-c ..scalar arguments..
- integer nu,nv
- real*8 x,y
-c ..array arguments..
- real*8 tu(nu),tv(nv),c((nu-4)*(nv-4))
-c ..user specified function
- real*8 rad
-c ..local scalars..
- integer ier
- real*8 u,v,r,f,one,dist
-c ..local arrays
- real*8 wrk(8)
- integer iwrk(2)
-c ..function references
- real*8 atan2,sqrt
-c ..
-c calculate the (u,v)-coordinates of the given point.
- one = 1
- u = 0.
- v = 0.
- dist = x**2+y**2
- if(dist.le.0.) go to 10
- v = atan2(y,x)
- r = rad(v)
- if(r.le.0.) go to 10
- u = sqrt(dist)/r
- if(u.gt.one) u = one
-c evaluate s(u,v)
- 10 call bispev(tu,nu,tv,nv,c,3,3,u,1,v,1,f,wrk,8,iwrk,2,ier)
- evapol = f
- return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fourco.f
===================================================================
--- branches/Interpolate1D/fitpack/fourco.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fourco.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,96 +0,0 @@
- subroutine fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier)
-c subroutine fourco calculates the integrals
-c /t(n-3)
-c ress(i) = ! s(x)*sin(alfa(i)*x) dx and
-c t(4)/
-c /t(n-3)
-c resc(i) = ! s(x)*cos(alfa(i)*x) dx, i=1,...,m,
-c t(4)/
-c where s(x) denotes a cubic spline which is given in its
-c b-spline representation.
-c
-c calling sequence:
-c call fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier)
-c
-c input parameters:
-c t : real array,length n, containing the knots of s(x).
-c n : integer, containing the total number of knots. n>=10.
-c c : real array,length n, containing the b-spline coefficients.
-c alfa : real array,length m, containing the parameters alfa(i).
-c m : integer, specifying the number of integrals to be computed.
-c wrk1 : real array,length n. used as working space
-c wrk2 : real array,length n. used as working space
-c
-c output parameters:
-c ress : real array,length m, containing the integrals ress(i).
-c resc : real array,length m, containing the integrals resc(i).
-c ier : error flag:
-c ier=0 : normal return.
-c ier=10: invalid input data (see restrictions).
-c
-c restrictions:
-c n >= 10
-c t(4) < t(5) < ... < t(n-4) < t(n-3).
-c t(1) <= t(2) <= t(3) <= t(4).
-c t(n-3) <= t(n-2) <= t(n-1) <= t(n).
-c
-c other subroutines required: fpbfou,fpcsin
-c
-c references :
-c dierckx p. : calculation of fouriercoefficients of discrete
-c functions using cubic splines. j. computational
-c and applied mathematics 3 (1977) 207-209.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer n,m,ier
-c ..array arguments..
- real*8 t(n),c(n),wrk1(n),wrk2(n),alfa(m),ress(m),resc(m)
-c ..local scalars..
- integer i,j,n4
- real*8 rs,rc
-c ..
- n4 = n-4
-c before starting computations a data check is made. in the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(n.lt.10) go to 50
- j = n
- do 10 i=1,3
- if(t(i).gt.t(i+1)) go to 50
- if(t(j).lt.t(j-1)) go to 50
- j = j-1
- 10 continue
- do 20 i=4,n4
- if(t(i).ge.t(i+1)) go to 50
- 20 continue
- ier = 0
-c main loop for the different alfa(i).
- do 40 i=1,m
-c calculate the integrals
-c wrk1(j) = integral(nj,4(x)*sin(alfa*x)) and
-c wrk2(j) = integral(nj,4(x)*cos(alfa*x)), j=1,2,...,n-4,
-c where nj,4(x) denotes the normalised cubic b-spline defined on the
-c knots t(j),t(j+1),...,t(j+4).
- call fpbfou(t,n,alfa(i),wrk1,wrk2)
-c calculate the integrals ress(i) and resc(i).
- rs = 0.
- rc = 0.
- do 30 j=1,n4
- rs = rs+c(j)*wrk1(j)
- rc = rc+c(j)*wrk2(j)
- 30 continue
- ress(i) = rs
- resc(i) = rc
- 40 continue
- 50 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpader.f
===================================================================
--- branches/Interpolate1D/fitpack/fpader.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpader.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,57 +0,0 @@
- subroutine fpader(t,n,c,k1,x,l,d)
-c subroutine fpader calculates the derivatives
-c (j-1)
-c d(j) = s (x) , j=1,2,...,k1
-c of a spline of order k1 at the point t(l)<=x<t(l+1), using the
-c stable recurrence scheme of de boor
-c ..
-c ..scalar arguments..
- real*8 x
- integer n,k1,l
-c ..array arguments..
- real*8 t(n),c(n),d(k1)
-c ..local scalars..
- integer i,ik,j,jj,j1,j2,ki,kj,li,lj,lk
- real*8 ak,fac,one
-c ..local array..
- real*8 h(20)
-c ..
- one = 0.1d+01
- lk = l-k1
- do 100 i=1,k1
- ik = i+lk
- h(i) = c(ik)
- 100 continue
- kj = k1
- fac = one
- do 700 j=1,k1
- ki = kj
- j1 = j+1
- if(j.eq.1) go to 300
- i = k1
- do 200 jj=j,k1
- li = i+lk
- lj = li+kj
- h(i) = (h(i)-h(i-1))/(t(lj)-t(li))
- i = i-1
- 200 continue
- 300 do 400 i=j,k1
- d(i) = h(i)
- 400 continue
- if(j.eq.k1) go to 600
- do 500 jj=j1,k1
- ki = ki-1
- i = k1
- do 500 j2=jj,k1
- li = i+lk
- lj = li+ki
- d(i) = ((x-t(li))*d(i)+(t(lj)-x)*d(i-1))/(t(lj)-t(li))
- i = i-1
- 500 continue
- 600 d(j) = d(k1)*fac
- ak = k1-j
- fac = fac*ak
- kj = kj-1
- 700 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpadno.f
===================================================================
--- branches/Interpolate1D/fitpack/fpadno.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpadno.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,59 +0,0 @@
- subroutine fpadno(maxtr,up,left,right,info,count,merk,jbind,
- * n1,ier)
-c subroutine fpadno adds a branch of length n1 to the triply linked
-c tree,the information of which is kept in the arrays up,left,right
-c and info. the information field of the nodes of this new branch is
-c given in the array jbind. in linking the new branch fpadno takes
-c account of the property of the tree that
-c info(k) < info(right(k)) ; info(k) < info(left(k))
-c if necessary the subroutine calls subroutine fpfrno to collect the
-c free nodes of the tree. if no computer words are available at that
-c moment, the error parameter ier is set to 1.
-c ..
-c ..scalar arguments..
- integer maxtr,count,merk,n1,ier
-c ..array arguments..
- integer up(maxtr),left(maxtr),right(maxtr),info(maxtr),jbind(n1)
-c ..local scalars..
- integer k,niveau,point
- logical bool
-c ..subroutine references..
-c fpfrno
-c ..
- point = 1
- niveau = 1
- 10 k = left(point)
- bool = .true.
- 20 if(k.eq.0) go to 50
- if (info(k)-jbind(niveau).lt.0) go to 30
- if (info(k)-jbind(niveau).eq.0) go to 40
- go to 50
- 30 point = k
- k = right(point)
- bool = .false.
- go to 20
- 40 point = k
- niveau = niveau+1
- go to 10
- 50 if(niveau.gt.n1) go to 90
- count = count+1
- if(count.le.maxtr) go to 60
- call fpfrno(maxtr,up,left,right,info,point,merk,n1,count,ier)
- if(ier.ne.0) go to 100
- 60 info(count) = jbind(niveau)
- left(count) = 0
- right(count) = k
- if(bool) go to 70
- bool = .true.
- right(point) = count
- up(count) = up(point)
- go to 80
- 70 up(count) = point
- left(point) = count
- 80 point = count
- niveau = niveau+1
- k = 0
- go to 50
- 90 ier = 0
- 100 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpadpo.f
===================================================================
--- branches/Interpolate1D/fitpack/fpadpo.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpadpo.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,70 +0,0 @@
- subroutine fpadpo(idim,t,n,c,nc,k,cp,np,cc,t1,t2)
-c given a idim-dimensional spline curve of degree k, in its b-spline
-c representation ( knots t(j),j=1,...,n , b-spline coefficients c(j),
-c j=1,...,nc) and given also a polynomial curve in its b-spline
-c representation ( coefficients cp(j), j=1,...,np), subroutine fpadpo
-c calculates the b-spline representation (coefficients c(j),j=1,...,nc)
-c of the sum of the two curves.
-c
-c other subroutine required : fpinst
-c
-c ..
-c ..scalar arguments..
- integer idim,k,n,nc,np
-c ..array arguments..
- real*8 t(n),c(nc),cp(np),cc(nc),t1(n),t2(n)
-c ..local scalars..
- integer i,ii,j,jj,k1,l,l1,n1,n2,nk1,nk2
-c ..
- k1 = k+1
- nk1 = n-k1
-c initialization
- j = 1
- l = 1
- do 20 jj=1,idim
- l1 = j
- do 10 ii=1,k1
- cc(l1) = cp(l)
- l1 = l1+1
- l = l+1
- 10 continue
- j = j+n
- l = l+k1
- 20 continue
- if(nk1.eq.k1) go to 70
- n1 = k1*2
- j = n
- l = n1
- do 30 i=1,k1
- t1(i) = t(i)
- t1(l) = t(j)
- l = l-1
- j = j-1
- 30 continue
-c find the b-spline representation of the given polynomial curve
-c according to the given set of knots.
- nk2 = nk1-1
- do 60 l=k1,nk2
- l1 = l+1
- j = 1
- do 40 i=1,idim
- call fpinst(0,t1,n1,cc(j),k,t(l1),l,t2,n2,cc(j),n)
- j = j+n
- 40 continue
- do 50 i=1,n2
- t1(i) = t2(i)
- 50 continue
- n1 = n2
- 60 continue
-c find the b-spline representation of the resulting curve.
- 70 j = 1
- do 90 jj=1,idim
- l = j
- do 80 i=1,nk1
- c(l) = cc(l)+c(l)
- l = l+1
- 80 continue
- j = j+n
- 90 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpback.f
===================================================================
--- branches/Interpolate1D/fitpack/fpback.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpback.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,31 +0,0 @@
- subroutine fpback(a,z,n,k,c,nest)
-c subroutine fpback calculates the solution of the system of
-c equations a*c = z with a a n x n upper triangular matrix
-c of bandwidth k.
-c ..
-c ..scalar arguments..
- integer n,k,nest
-c ..array arguments..
- real*8 a(nest,k),z(n),c(n)
-c ..local scalars..
- real*8 store
- integer i,i1,j,k1,l,m
-c ..
- k1 = k-1
- c(n) = z(n)/a(n,1)
- i = n-1
- if(i.eq.0) go to 30
- do 20 j=2,n
- store = z(i)
- i1 = k1
- if(j.le.k1) i1 = j-1
- m = i
- do 10 l=1,i1
- m = m+1
- store = store-c(m)*a(i,l+1)
- 10 continue
- c(i) = store/a(i,1)
- i = i-1
- 20 continue
- 30 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpbacp.f
===================================================================
--- branches/Interpolate1D/fitpack/fpbacp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpbacp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,58 +0,0 @@
- subroutine fpbacp(a,b,z,n,k,c,k1,nest)
-c subroutine fpbacp calculates the solution of the system of equations
-c g * c = z with g a n x n upper triangular matrix of the form
-c ! a ' !
-c g = ! ' b !
-c ! 0 ' !
-c with b a n x k matrix and a a (n-k) x (n-k) upper triangular
-c matrix of bandwidth k1.
-c ..
-c ..scalar arguments..
- integer n,k,k1,nest
-c ..array arguments..
- real*8 a(nest,k1),b(nest,k),z(n),c(n)
-c ..local scalars..
- integer i,i1,j,l,l0,l1,n2
- real*8 store
-c ..
- n2 = n-k
- l = n
- do 30 i=1,k
- store = z(l)
- j = k+2-i
- if(i.eq.1) go to 20
- l0 = l
- do 10 l1=j,k
- l0 = l0+1
- store = store-c(l0)*b(l,l1)
- 10 continue
- 20 c(l) = store/b(l,j-1)
- l = l-1
- if(l.eq.0) go to 80
- 30 continue
- do 50 i=1,n2
- store = z(i)
- l = n2
- do 40 j=1,k
- l = l+1
- store = store-c(l)*b(i,j)
- 40 continue
- c(i) = store
- 50 continue
- i = n2
- c(i) = c(i)/a(i,1)
- if(i.eq.1) go to 80
- do 70 j=2,n2
- i = i-1
- store = c(i)
- i1 = k
- if(j.le.k) i1=j-1
- l = i
- do 60 l0=1,i1
- l = l+1
- store = store-c(l)*a(i,l0+1)
- 60 continue
- c(i) = store/a(i,1)
- 70 continue
- 80 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpbfout.f
===================================================================
--- branches/Interpolate1D/fitpack/fpbfout.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpbfout.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,197 +0,0 @@
- subroutine fpbfou(t,n,par,ress,resc)
-c subroutine fpbfou calculates the integrals
-c /t(n-3)
-c ress(j) = ! nj,4(x)*sin(par*x) dx and
-c t(4)/
-c /t(n-3)
-c resc(j) = ! nj,4(x)*cos(par*x) dx , j=1,2,...n-4
-c t(4)/
-c where nj,4(x) denotes the cubic b-spline defined on the knots
-c t(j),t(j+1),...,t(j+4).
-c
-c calling sequence:
-c call fpbfou(t,n,par,ress,resc)
-c
-c input parameters:
-c t : real array,length n, containing the knots.
-c n : integer, containing the number of knots.
-c par : real, containing the value of the parameter par.
-c
-c output parameters:
-c ress : real array,length n, containing the integrals ress(j).
-c resc : real array,length n, containing the integrals resc(j).
-c
-c restrictions:
-c n >= 10, t(4) < t(5) < ... < t(n-4) < t(n-3).
-c ..
-c ..scalar arguments..
- integer n
- real*8 par
-c ..array arguments..
- real*8 t(n),ress(n),resc(n)
-c ..local scalars..
- integer i,ic,ipj,is,j,jj,jp1,jp4,k,li,lj,ll,nmj,nm3,nm7
- real*8 ak,beta,con1,con2,c1,c2,delta,eps,fac,f1,f2,f3,one,quart,
- * sign,six,s1,s2,term
-c ..local arrays..
- real*8 co(5),si(5),hs(5),hc(5),rs(3),rc(3)
-c ..function references..
- real*8 cos,sin,abs
-c ..
-c initialization.
- one = 0.1e+01
- six = 0.6e+01
- eps = 0.1e-07
- quart = 0.25e0
- con1 = 0.5e-01
- con2 = 0.12e+03
- nm3 = n-3
- nm7 = n-7
- if(par.ne.0.) term = six/par
- beta = par*t(4)
- co(1) = cos(beta)
- si(1) = sin(beta)
-c calculate the integrals ress(j) and resc(j), j=1,2,3 by setting up
-c a divided difference table.
- do 30 j=1,3
- jp1 = j+1
- jp4 = j+4
- beta = par*t(jp4)
- co(jp1) = cos(beta)
- si(jp1) = sin(beta)
- call fpcsin(t(4),t(jp4),par,si(1),co(1),si(jp1),co(jp1),
- * rs(j),rc(j))
- i = 5-j
- hs(i) = 0.
- hc(i) = 0.
- do 10 jj=1,j
- ipj = i+jj
- hs(ipj) = rs(jj)
- hc(ipj) = rc(jj)
- 10 continue
- do 20 jj=1,3
- if(i.lt.jj) i = jj
- k = 5
- li = jp4
- do 20 ll=i,4
- lj = li-jj
- fac = t(li)-t(lj)
- hs(k) = (hs(k)-hs(k-1))/fac
- hc(k) = (hc(k)-hc(k-1))/fac
- k = k-1
- li = li-1
- 20 continue
- ress(j) = hs(5)-hs(4)
- resc(j) = hc(5)-hc(4)
- 30 continue
- if(nm7.lt.4) go to 160
-c calculate the integrals ress(j) and resc(j),j=4,5,...,n-7.
- do 150 j=4,nm7
- jp4 = j+4
- beta = par*t(jp4)
- co(5) = cos(beta)
- si(5) = sin(beta)
- delta = t(jp4)-t(j)
-c the way of computing ress(j) and resc(j) depends on the value of
-c beta = par*(t(j+4)-t(j)).
- beta = delta*par
- if(abs(beta).le.one) go to 60
-c if !beta! > 1 the integrals are calculated by setting up a divided
-c difference table.
- do 40 k=1,5
- hs(k) = si(k)
- hc(k) = co(k)
- 40 continue
- do 50 jj=1,3
- k = 5
- li = jp4
- do 50 ll=jj,4
- lj = li-jj
- fac = par*(t(li)-t(lj))
- hs(k) = (hs(k)-hs(k-1))/fac
- hc(k) = (hc(k)-hc(k-1))/fac
- k = k-1
- li = li-1
- 50 continue
- s2 = (hs(5)-hs(4))*term
- c2 = (hc(5)-hc(4))*term
- go to 130
-c if !beta! <= 1 the integrals are calculated by evaluating a series
-c expansion.
- 60 f3 = 0.
- do 70 i=1,4
- ipj = i+j
- hs(i) = par*(t(ipj)-t(j))
- hc(i) = hs(i)
- f3 = f3+hs(i)
- 70 continue
- f3 = f3*con1
- c1 = quart
- s1 = f3
- if(abs(f3).le.eps) go to 120
- sign = one
- fac = con2
- k = 5
- is = 0
- do 110 ic=1,20
- k = k+1
- ak = k
- fac = fac*ak
- f1 = 0.
- f3 = 0.
- do 80 i=1,4
- f1 = f1+hc(i)
- f2 = f1*hs(i)
- hc(i) = f2
- f3 = f3+f2
- 80 continue
- f3 = f3*six/fac
- if(is.eq.0) go to 90
- is = 0
- s1 = s1+f3*sign
- go to 100
- 90 sign = -sign
- is = 1
- c1 = c1+f3*sign
- 100 if(abs(f3).le.eps) go to 120
- 110 continue
- 120 s2 = delta*(co(1)*s1+si(1)*c1)
- c2 = delta*(co(1)*c1-si(1)*s1)
- 130 ress(j) = s2
- resc(j) = c2
- do 140 i=1,4
- co(i) = co(i+1)
- si(i) = si(i+1)
- 140 continue
- 150 continue
-c calculate the integrals ress(j) and resc(j),j=n-6,n-5,n-4 by setting
-c up a divided difference table.
- 160 do 190 j=1,3
- nmj = nm3-j
- i = 5-j
- call fpcsin(t(nm3),t(nmj),par,si(4),co(4),si(i-1),co(i-1),
- * rs(j),rc(j))
- hs(i) = 0.
- hc(i) = 0.
- do 170 jj=1,j
- ipj = i+jj
- hc(ipj) = rc(jj)
- hs(ipj) = rs(jj)
- 170 continue
- do 180 jj=1,3
- if(i.lt.jj) i = jj
- k = 5
- li = nmj
- do 180 ll=i,4
- lj = li+jj
- fac = t(lj)-t(li)
- hs(k) = (hs(k-1)-hs(k))/fac
- hc(k) = (hc(k-1)-hc(k))/fac
- k = k-1
- li = li+1
- 180 continue
- ress(nmj) = hs(4)-hs(5)
- resc(nmj) = hc(4)-hc(5)
- 190 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpbisp.f
===================================================================
--- branches/Interpolate1D/fitpack/fpbisp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpbisp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,79 +0,0 @@
- subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wx,wy,lx,ly)
-c ..scalar arguments..
- integer nx,ny,kx,ky,mx,my
-c ..array arguments..
- integer lx(mx),ly(my)
- real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my),
- * wx(mx,kx+1),wy(my,ky+1)
-c ..local scalars..
- integer kx1,ky1,l,l1,l2,m,nkx1,nky1
- real*8 arg,sp,tb,te
-c ..local arrays..
- real*8 h(6)
-c ..subroutine references..
-c fpbspl
-c ..
- kx1 = kx+1
- nkx1 = nx-kx1
- tb = tx(kx1)
- te = tx(nkx1+1)
- l = kx1
- l1 = l+1
- do 40 i=1,mx
- arg = x(i)
- if(arg.lt.tb) arg = tb
- if(arg.gt.te) arg = te
- 10 if(arg.lt.tx(l1) .or. l.eq.nkx1) go to 20
- l = l1
- l1 = l+1
- go to 10
- 20 call fpbspl(tx,nx,kx,arg,l,h)
- lx(i) = l-kx1
- do 30 j=1,kx1
- wx(i,j) = h(j)
- 30 continue
- 40 continue
- ky1 = ky+1
- nky1 = ny-ky1
- tb = ty(ky1)
- te = ty(nky1+1)
- l = ky1
- l1 = l+1
- do 80 i=1,my
- arg = y(i)
- if(arg.lt.tb) arg = tb
- if(arg.gt.te) arg = te
- 50 if(arg.lt.ty(l1) .or. l.eq.nky1) go to 60
- l = l1
- l1 = l+1
- go to 50
- 60 call fpbspl(ty,ny,ky,arg,l,h)
- ly(i) = l-ky1
- do 70 j=1,ky1
- wy(i,j) = h(j)
- 70 continue
- 80 continue
- m = 0
- do 130 i=1,mx
- l = lx(i)*nky1
- do 90 i1=1,kx1
- h(i1) = wx(i,i1)
- 90 continue
- do 120 j=1,my
- l1 = l+ly(j)
- sp = 0.
- do 110 i1=1,kx1
- l2 = l1
- do 100 j1=1,ky1
- l2 = l2+1
- sp = sp+c(l2)*h(i1)*wy(j,j1)
- 100 continue
- l1 = l1+nky1
- 110 continue
- m = m+1
- z(m) = sp
- 120 continue
- 130 continue
- return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpbspl.f
===================================================================
--- branches/Interpolate1D/fitpack/fpbspl.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpbspl.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,42 +0,0 @@
- subroutine fpbspl(t,n,k,x,l,h)
-c subroutine fpbspl evaluates the (k+1) non-zero b-splines of
-c degree k at t(l) <= x < t(l+1) using the stable recurrence
-c relation of de boor and cox.
-c Travis Oliphant 2007
-c changed so that weighting of 0 is used when knots with
-c multiplicity are present.
-c Also, notice that l+k <= n and 1 <= l+1-k
-c or else the routine will be accessing memory outside t
-c Thus it is imperative that that k <= l <= n-k but this
-c is not checked.
-c ..
-c ..scalar arguments..
- real*8 x
- integer n,k,l
-c ..array arguments..
- real*8 t(n),h(20)
-c ..local scalars..
- real*8 f,one
- integer i,j,li,lj
-c ..local arrays..
- real*8 hh(19)
-c ..
- one = 0.1d+01
- h(1) = one
- do 20 j=1,k
- do 10 i=1,j
- hh(i) = h(i)
- 10 continue
- h(1) = 0.0d0
- do 20 i=1,j
- li = l+i
- lj = li-j
- if (t(li).ne.t(lj)) goto 15
- h(i+1) = 0.0d0
- goto 20
- 15 f = hh(i)/(t(li)-t(lj))
- h(i) = h(i)+f*(t(li)-x)
- h(i+1) = f*(x-t(lj))
- 20 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpchec.f
===================================================================
--- branches/Interpolate1D/fitpack/fpchec.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpchec.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,62 +0,0 @@
- subroutine fpchec(x,m,t,n,k,ier)
-c subroutine fpchec verifies the number and the position of the knots
-c t(j),j=1,2,...,n of a spline of degree k, in relation to the number
-c and the position of the data points x(i),i=1,2,...,m. if all of the
-c following conditions are fulfilled, the error parameter ier is set
-c to zero. if one of the conditions is violated ier is set to ten.
-c 1) k+1 <= n-k-1 <= m
-c 2) t(1) <= t(2) <= ... <= t(k+1)
-c t(n-k) <= t(n-k+1) <= ... <= t(n)
-c 3) t(k+1) < t(k+2) < ... < t(n-k)
-c 4) t(k+1) <= x(i) <= t(n-k)
-c 5) the conditions specified by schoenberg and whitney must hold
-c for at least one subset of data points, i.e. there must be a
-c subset of data points y(j) such that
-c t(j) < y(j) < t(j+k+1), j=1,2,...,n-k-1
-c ..
-c ..scalar arguments..
- integer m,n,k,ier
-c ..array arguments..
- real*8 x(m),t(n)
-c ..local scalars..
- integer i,j,k1,k2,l,nk1,nk2,nk3
- real*8 tj,tl
-c ..
- k1 = k+1
- k2 = k1+1
- nk1 = n-k1
- nk2 = nk1+1
- ier = 10
-c check condition no 1
- if(nk1.lt.k1 .or. nk1.gt.m) go to 80
-c check condition no 2
- j = n
- do 20 i=1,k
- if(t(i).gt.t(i+1)) go to 80
- if(t(j).lt.t(j-1)) go to 80
- j = j-1
- 20 continue
-c check condition no 3
- do 30 i=k2,nk2
- if(t(i).le.t(i-1)) go to 80
- 30 continue
-c check condition no 4
- if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80
-c check condition no 5
- if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80
- i = 1
- l = k2
- nk3 = nk1-1
- if(nk3.lt.2) go to 70
- do 60 j=2,nk3
- tj = t(j)
- l = l+1
- tl = t(l)
- 40 i = i+1
- if(i.ge.m) go to 80
- if(x(i).le.tj) go to 40
- if(x(i).ge.tl) go to 80
- 60 continue
- 70 ier = 0
- 80 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpched.f
===================================================================
--- branches/Interpolate1D/fitpack/fpched.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpched.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,69 +0,0 @@
- subroutine fpched(x,m,t,n,k,ib,ie,ier)
-c subroutine fpched verifies the number and the position of the knots
-c t(j),j=1,2,...,n of a spline of degree k,with ib derative constraints
-c at x(1) and ie constraints at x(m), in relation to the number and
-c the position of the data points x(i),i=1,2,...,m. if all of the
-c following conditions are fulfilled, the error parameter ier is set
-c to zero. if one of the conditions is violated ier is set to ten.
-c 1) k+1 <= n-k-1 <= m + max(0,ib-1) + max(0,ie-1)
-c 2) t(1) <= t(2) <= ... <= t(k+1)
-c t(n-k) <= t(n-k+1) <= ... <= t(n)
-c 3) t(k+1) < t(k+2) < ... < t(n-k)
-c 4) t(k+1) <= x(i) <= t(n-k)
-c 5) the conditions specified by schoenberg and whitney must hold
-c for at least one subset of data points, i.e. there must be a
-c subset of data points y(j) such that
-c t(j) < y(j) < t(j+k+1), j=1+ib1,2+ib1,...,n-k-1-ie1
-c with ib1 = max(0,ib-1), ie1 = max(0,ie-1)
-c ..
-c ..scalar arguments..
- integer m,n,k,ib,ie,ier
-c ..array arguments..
- real*8 x(m),t(n)
-c ..local scalars..
- integer i,ib1,ie1,j,jj,k1,k2,l,nk1,nk2,nk3
- real*8 tj,tl
-c ..
- k1 = k+1
- k2 = k1+1
- nk1 = n-k1
- nk2 = nk1+1
- ib1 = ib-1
- if(ib1.lt.0) ib1 = 0
- ie1 = ie-1
- if(ie1.lt.0) ie1 = 0
- ier = 10
-c check condition no 1
- if(nk1.lt.k1 .or. nk1.gt.(m+ib1+ie1)) go to 80
-c check condition no 2
- j = n
- do 20 i=1,k
- if(t(i).gt.t(i+1)) go to 80
- if(t(j).lt.t(j-1)) go to 80
- j = j-1
- 20 continue
-c check condition no 3
- do 30 i=k2,nk2
- if(t(i).le.t(i-1)) go to 80
- 30 continue
-c check condition no 4
- if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80
-c check condition no 5
- if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80
- i = 1
- jj = 2+ib1
- l = jj+k
- nk3 = nk1-1-ie1
- if(nk3.lt.jj) go to 70
- do 60 j=jj,nk3
- tj = t(j)
- l = l+1
- tl = t(l)
- 40 i = i+1
- if(i.ge.m) go to 80
- if(x(i).le.tj) go to 40
- if(x(i).ge.tl) go to 80
- 60 continue
- 70 ier = 0
- 80 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpchep.f
===================================================================
--- branches/Interpolate1D/fitpack/fpchep.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpchep.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,81 +0,0 @@
- subroutine fpchep(x,m,t,n,k,ier)
-c subroutine fpchep verifies the number and the position of the knots
-c t(j),j=1,2,...,n of a periodic spline of degree k, in relation to
-c the number and the position of the data points x(i),i=1,2,...,m.
-c if all of the following conditions are fulfilled, ier is set
-c to zero. if one of the conditions is violated ier is set to ten.
-c 1) k+1 <= n-k-1 <= m+k-1
-c 2) t(1) <= t(2) <= ... <= t(k+1)
-c t(n-k) <= t(n-k+1) <= ... <= t(n)
-c 3) t(k+1) < t(k+2) < ... < t(n-k)
-c 4) t(k+1) <= x(i) <= t(n-k)
-c 5) the conditions specified by schoenberg and whitney must hold
-c for at least one subset of data points, i.e. there must be a
-c subset of data points y(j) such that
-c t(j) < y(j) < t(j+k+1), j=k+1,...,n-k-1
-c ..
-c ..scalar arguments..
- integer m,n,k,ier
-c ..array arguments..
- real*8 x(m),t(n)
-c ..local scalars..
- integer i,i1,i2,j,j1,k1,k2,l,l1,l2,mm,m1,nk1,nk2
- real*8 per,tj,tl,xi
-c ..
- k1 = k+1
- k2 = k1+1
- nk1 = n-k1
- nk2 = nk1+1
- m1 = m-1
- ier = 10
-c check condition no 1
- if(nk1.lt.k1 .or. n.gt.m+2*k) go to 130
-c check condition no 2
- j = n
- do 20 i=1,k
- if(t(i).gt.t(i+1)) go to 130
- if(t(j).lt.t(j-1)) go to 130
- j = j-1
- 20 continue
-c check condition no 3
- do 30 i=k2,nk2
- if(t(i).le.t(i-1)) go to 130
- 30 continue
-c check condition no 4
- if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 130
-c check condition no 5
- l1 = k1
- l2 = 1
- do 50 l=1,m
- xi = x(l)
- 40 if(xi.lt.t(l1+1) .or. l.eq.nk1) go to 50
- l1 = l1+1
- l2 = l2+1
- if(l2.gt.k1) go to 60
- go to 40
- 50 continue
- l = m
- 60 per = t(nk2)-t(k1)
- do 120 i1=2,l
- i = i1-1
- mm = i+m1
- do 110 j=k1,nk1
- tj = t(j)
- j1 = j+k1
- tl = t(j1)
- 70 i = i+1
- if(i.gt.mm) go to 120
- i2 = i-m1
- if (i2.le.0) go to 80
- go to 90
- 80 xi = x(i)
- go to 100
- 90 xi = x(i2)+per
- 100 if(xi.le.tj) go to 70
- if(xi.ge.tl) go to 120
- 110 continue
- ier = 0
- go to 130
- 120 continue
- 130 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpclos.f
===================================================================
--- branches/Interpolate1D/fitpack/fpclos.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpclos.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,714 +0,0 @@
- subroutine fpclos(iopt,idim,m,u,mx,x,w,k,s,nest,tol,maxit,k1,k2,
- * n,t,nc,c,fp,fpint,z,a1,a2,b,g1,g2,q,nrdata,ier)
-c ..
-c ..scalar arguments..
- real*8 s,tol,fp
- integer iopt,idim,m,mx,k,nest,maxit,k1,k2,n,nc,ier
-c ..array arguments..
- real*8 u(m),x(mx),w(m),t(nest),c(nc),fpint(nest),z(nc),a1(nest,k1)
- *,
- * a2(nest,k),b(nest,k2),g1(nest,k2),g2(nest,k1),q(m,k1)
- integer nrdata(nest)
-c ..local scalars..
- real*8 acc,cos,d1,fac,fpart,fpms,fpold,fp0,f1,f2,f3,p,per,pinv,piv
- *,
- * p1,p2,p3,sin,store,term,ui,wi,rn,one,con1,con4,con9,half
- integer i,ich1,ich3,ij,ik,it,iter,i1,i2,i3,j,jj,jk,jper,j1,j2,kk,
- * kk1,k3,l,l0,l1,l5,mm,m1,new,nk1,nk2,nmax,nmin,nplus,npl1,
- * nrint,n10,n11,n7,n8
-c ..local arrays..
- real*8 h(6),h1(7),h2(6),xi(10)
-c ..function references..
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota
-c ..
-c set constants
- one = 0.1e+01
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- half = 0.5e0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position c
-c ************************************************************** c
-c given a set of knots we compute the least-squares closed curve c
-c sinf(u). if the sum f(p=inf) <= s we accept the choice of knots. c
-c if iopt=-1 sinf(u) is the requested curve c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares curve until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmax = m+2*k. c
-c if s > 0 and c
-c iopt=0 we first compute the least-squares polynomial curve of c
-c degree k; n = nmin = 2*k+2. since s(u) must be periodic we c
-c find that s(u) reduces to a fixed point. c
-c iopt=1 we start with the set of knots found at the last c
-c call of the routine, except for the case that s > fp0; then c
-c we compute directly the least-squares polynomial curve. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- m1 = m-1
- kk = k
- kk1 = k1
- k3 = 3*k+1
- nmin = 2*k1
-c determine the length of the period of the splines.
- per = u(m)-u(1)
- if(iopt.lt.0) go to 50
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c determine nmax, the number of knots for periodic spline interpolation
- nmax = m+2*k
- if(s.gt.0. .or. nmax.eq.nmin) go to 30
-c if s=0, s(u) is an interpolating curve.
- n = nmax
-c test whether the required storage space exceeds the available one.
- if(n.gt.nest) go to 620
-c find the position of the interior knots in case of interpolation.
- 5 if((k/2)*2 .eq.k) go to 20
- do 10 i=2,m1
- j = i+k
- t(j) = u(i)
- 10 continue
- if(s.gt.0.) go to 50
- kk = k-1
- kk1 = k
- if(kk.gt.0) go to 50
- t(1) = t(m)-per
- t(2) = u(1)
- t(m+1) = u(m)
- t(m+2) = t(3)+per
- jj = 0
- do 15 i=1,m1
- j = i
- do 12 j1=1,idim
- jj = jj+1
- c(j) = x(jj)
- j = j+n
- 12 continue
- 15 continue
- jj = 1
- j = m
- do 17 j1=1,idim
- c(j) = c(jj)
- j = j+n
- jj = jj+n
- 17 continue
- fp = 0.
- fpint(n) = fp0
- fpint(n-1) = 0.
- nrdata(n) = 0
- go to 630
- 20 do 25 i=2,m1
- j = i+k
- t(j) = (u(i)+u(i-1))*half
- 25 continue
- go to 50
-c if s > 0 our initial choice depends on the value of iopt.
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c polynomial curve. (i.e. a constant point).
-c if iopt=1 and fp0>s we start computing the least-squares closed
-c curve according the set of knots found at the last call of the
-c routine.
- 30 if(iopt.eq.0) go to 35
- if(n.eq.nmin) go to 35
- fp0 = fpint(n)
- fpold = fpint(n-1)
- nplus = nrdata(n)
- if(fp0.gt.s) go to 50
-c the case that s(u) is a fixed point is treated separetely.
-c fp0 denotes the corresponding sum of squared residuals.
- 35 fp0 = 0.
- d1 = 0.
- do 37 j=1,idim
- z(j) = 0.
- 37 continue
- jj = 0
- do 45 it=1,m1
- wi = w(it)
- call fpgivs(wi,d1,cos,sin)
- do 40 j=1,idim
- jj = jj+1
- fac = wi*x(jj)
- call fprota(cos,sin,fac,z(j))
- fp0 = fp0+fac**2
- 40 continue
- 45 continue
- do 47 j=1,idim
- z(j) = z(j)/d1
- 47 continue
-c test whether that fixed point is a solution of our problem.
- fpms = fp0-s
- if(fpms.lt.acc .or. nmax.eq.nmin) go to 640
- fpold = fp0
-c test whether the required storage space exceeds the available one.
- if(n.ge.nest) go to 620
-c start computing the least-squares closed curve with one
-c interior knot.
- nplus = 1
- n = nmin+1
- mm = (m+1)/2
- t(k2) = u(mm)
- nrdata(1) = mm-2
- nrdata(2) = m1-mm
-c main loop for the different sets of knots. m is a save upper
-c bound for the number of trials.
- 50 do 340 iter=1,m
-c find nrint, the number of knot intervals.
- nrint = n-nmin+1
-c find the position of the additional knots which are needed for
-c the b-spline representation of s(u). if we take
-c t(k+1) = u(1), t(n-k) = u(m)
-c t(k+1-j) = t(n-k-j) - per, j=1,2,...k
-c t(n-k+j) = t(k+1+j) + per, j=1,2,...k
-c then s(u) will be a smooth closed curve if the b-spline
-c coefficients satisfy the following conditions
-c c((i-1)*n+n7+j) = c((i-1)*n+j), j=1,...k,i=1,2,...,idim (**)
-c with n7=n-2*k-1.
- t(k1) = u(1)
- nk1 = n-k1
- nk2 = nk1+1
- t(nk2) = u(m)
- do 60 j=1,k
- i1 = nk2+j
- i2 = nk2-j
- j1 = k1+j
- j2 = k1-j
- t(i1) = t(j1)+per
- t(j2) = t(i2)-per
- 60 continue
-c compute the b-spline coefficients of the least-squares closed curve
-c sinf(u). the observation matrix a is built up row by row while
-c taking into account condition (**) and is reduced to triangular
-c form by givens transformations .
-c at the same time fp=f(p=inf) is computed.
-c the n7 x n7 triangularised upper matrix a has the form
-c ! a1 ' !
-c a = ! ' a2 !
-c ! 0 ' !
-c with a2 a n7 x k matrix and a1 a n10 x n10 upper triangular
-c matrix of bandwith k+1 ( n10 = n7-k).
-c initialization.
- do 65 i=1,nc
- z(i) = 0.
- 65 continue
- do 70 i=1,nk1
- do 70 j=1,kk1
- a1(i,j) = 0.
- 70 continue
- n7 = nk1-k
- n10 = n7-kk
- jper = 0
- fp = 0.
- l = k1
- jj = 0
- do 290 it=1,m1
-c fetch the current data point u(it),x(it)
- ui = u(it)
- wi = w(it)
- do 75 j=1,idim
- jj = jj+1
- xi(j) = x(jj)*wi
- 75 continue
-c search for knot interval t(l) <= ui < t(l+1).
- 80 if(ui.lt.t(l+1)) go to 85
- l = l+1
- go to 80
-c evaluate the (k+1) non-zero b-splines at ui and store them in q.
- 85 call fpbspl(t,n,k,ui,l,h)
- do 90 i=1,k1
- q(it,i) = h(i)
- h(i) = h(i)*wi
- 90 continue
- l5 = l-k1
-c test whether the b-splines nj,k+1(u),j=1+n7,...nk1 are all zero at ui
- if(l5.lt.n10) go to 285
- if(jper.ne.0) go to 160
-c initialize the matrix a2.
- do 95 i=1,n7
- do 95 j=1,kk
- a2(i,j) = 0.
- 95 continue
- jk = n10+1
- do 110 i=1,kk
- ik = jk
- do 100 j=1,kk1
- if(ik.le.0) go to 105
- a2(ik,i) = a1(ik,j)
- ik = ik-1
- 100 continue
- 105 jk = jk+1
- 110 continue
- jper = 1
-c if one of the b-splines nj,k+1(u),j=n7+1,...nk1 is not zero at ui
-c we take account of condition (**) for setting up the new row
-c of the observation matrix a. this row is stored in the arrays h1
-c (the part with respect to a1) and h2 (the part with
-c respect to a2).
- 160 do 170 i=1,kk
- h1(i) = 0.
- h2(i) = 0.
- 170 continue
- h1(kk1) = 0.
- j = l5-n10
- do 210 i=1,kk1
- j = j+1
- l0 = j
- 180 l1 = l0-kk
- if(l1.le.0) go to 200
- if(l1.le.n10) go to 190
- l0 = l1-n10
- go to 180
- 190 h1(l1) = h(i)
- go to 210
- 200 h2(l0) = h2(l0)+h(i)
- 210 continue
-c rotate the new row of the observation matrix into triangle
-c by givens transformations.
- if(n10.le.0) go to 250
-c rotation with the rows 1,2,...n10 of matrix a.
- do 240 j=1,n10
- piv = h1(1)
- if(piv.ne.0.) go to 214
- do 212 i=1,kk
- h1(i) = h1(i+1)
- 212 continue
- h1(kk1) = 0.
- go to 240
-c calculate the parameters of the givens transformation.
- 214 call fpgivs(piv,a1(j,1),cos,sin)
-c transformation to the right hand side.
- j1 = j
- do 217 j2=1,idim
- call fprota(cos,sin,xi(j2),z(j1))
- j1 = j1+n
- 217 continue
-c transformations to the left hand side with respect to a2.
- do 220 i=1,kk
- call fprota(cos,sin,h2(i),a2(j,i))
- 220 continue
- if(j.eq.n10) go to 250
- i2 = min0(n10-j,kk)
-c transformations to the left hand side with respect to a1.
- do 230 i=1,i2
- i1 = i+1
- call fprota(cos,sin,h1(i1),a1(j,i1))
- h1(i) = h1(i1)
- 230 continue
- h1(i1) = 0.
- 240 continue
-c rotation with the rows n10+1,...n7 of matrix a.
- 250 do 270 j=1,kk
- ij = n10+j
- if(ij.le.0) go to 270
- piv = h2(j)
- if(piv.eq.0.) go to 270
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a2(ij,j),cos,sin)
-c transformations to right hand side.
- j1 = ij
- do 255 j2=1,idim
- call fprota(cos,sin,xi(j2),z(j1))
- j1 = j1+n
- 255 continue
- if(j.eq.kk) go to 280
- j1 = j+1
-c transformations to left hand side.
- do 260 i=j1,kk
- call fprota(cos,sin,h2(i),a2(ij,i))
- 260 continue
- 270 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 280 do 282 j2=1,idim
- fp = fp+xi(j2)**2
- 282 continue
- go to 290
-c rotation of the new row of the observation matrix into
-c triangle in case the b-splines nj,k+1(u),j=n7+1,...n-k-1 are all zero
-c at ui.
- 285 j = l5
- do 140 i=1,kk1
- j = j+1
- piv = h(i)
- if(piv.eq.0.) go to 140
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a1(j,1),cos,sin)
-c transformations to right hand side.
- j1 = j
- do 125 j2=1,idim
- call fprota(cos,sin,xi(j2),z(j1))
- j1 = j1+n
- 125 continue
- if(i.eq.kk1) go to 150
- i2 = 1
- i3 = i+1
-c transformations to left hand side.
- do 130 i1=i3,kk1
- i2 = i2+1
- call fprota(cos,sin,h(i1),a1(j,i2))
- 130 continue
- 140 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 150 do 155 j2=1,idim
- fp = fp+xi(j2)**2
- 155 continue
- 290 continue
- fpint(n) = fp0
- fpint(n-1) = fpold
- nrdata(n) = nplus
-c backward substitution to obtain the b-spline coefficients .
- j1 = 1
- do 292 j2=1,idim
- call fpbacp(a1,a2,z(j1),n7,kk,c(j1),kk1,nest)
- j1 = j1+n
- 292 continue
-c calculate from condition (**) the remaining coefficients.
- do 297 i=1,k
- j1 = i
- do 295 j=1,idim
- j2 = j1+n7
- c(j2) = c(j1)
- j1 = j1+n
- 295 continue
- 297 continue
- if(iopt.lt.0) go to 660
-c test whether the approximation sinf(u) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 660
-c if f(p=inf) < s accept the choice of knots.
- if(fpms.lt.0.) go to 350
-c if n=nmax, sinf(u) is an interpolating curve.
- if(n.eq.nmax) go to 630
-c increase the number of knots.
-c if n=nest we cannot increase the number of knots because of the
-c storage capacity limitation.
- if(n.eq.nest) go to 620
-c determine the number of knots nplus we are going to add.
- npl1 = nplus*2
- rn = nplus
- if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp)
- nplus = min0(nplus*2,max0(npl1,nplus/2,1))
- fpold = fp
-c compute the sum of squared residuals for each knot interval
-c t(j+k) <= ui <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint.
- fpart = 0.
- i = 1
- l = k1
- jj = 0
- do 320 it=1,m1
- if(u(it).lt.t(l)) go to 300
- new = 1
- l = l+1
- 300 term = 0.
- l0 = l-k2
- do 310 j2=1,idim
- fac = 0.
- j1 = l0
- do 305 j=1,k1
- j1 = j1+1
- fac = fac+c(j1)*q(it,j)
- 305 continue
- jj = jj+1
- term = term+(w(it)*(fac-x(jj)))**2
- l0 = l0+n
- 310 continue
- fpart = fpart+term
- if(new.eq.0) go to 320
- if(l.gt.k2) go to 315
- fpint(nrint) = term
- new = 0
- go to 320
- 315 store = term*half
- fpint(i) = fpart-store
- i = i+1
- fpart = store
- new = 0
- 320 continue
- fpint(nrint) = fpint(nrint)+fpart
- do 330 l=1,nplus
-c add a new knot
- call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1)
-c if n=nmax we locate the knots as for interpolation
- if(n.eq.nmax) go to 5
-c test whether we cannot further increase the number of knots.
- if(n.eq.nest) go to 340
- 330 continue
-c restart the computations with the new set of knots.
- 340 continue
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing closed curve sp(u). c
-c ********************************************************** c
-c we have determined the number of knots and their position. c
-c we now compute the b-spline coefficients of the smoothing curve c
-c sp(u). the observation matrix a is extended by the rows of matrix c
-c b expressing that the kth derivative discontinuities of sp(u) at c
-c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c
-c ponding weights of these additional rows are set to 1/p. c
-c iteratively we then have to determine the value of p such that f(p),c
-c the sum of squared residuals be = s. we already know that the least-c
-c squares polynomial curve corresponds to p=0, and that the least- c
-c squares periodic spline curve corresponds to p=infinity. the c
-c iteration process which is proposed here, makes use of rational c
-c interpolation. since f(p) is a convex and strictly decreasing c
-c function of p, it can be approximated by a rational function c
-c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c
-c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c
-c to calculate the new value of p such that r(p)=s. convergence is c
-c guaranteed by taking f1>0 and f3<0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jump of the kth derivative of the
-c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b.
- 350 call fpdisc(t,n,k2,b,nest)
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- n11 = n10-1
- n8 = n7-1
- p = 0.
- l = n7
- do 352 i=1,k
- j = k+1-i
- p = p+a2(l,j)
- l = l-1
- if(l.eq.0) go to 356
- 352 continue
- do 354 i=1,n10
- p = p+a1(i,1)
- 354 continue
- 356 rn = n7
- p = rn/p
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p) = s.
- do 595 iter=1,maxit
-c form the matrix g as the matrix a extended by the rows of matrix b.
-c the rows of matrix b with weight 1/p are rotated into
-c the triangularised observation matrix a.
-c after triangularisation our n7 x n7 matrix g takes the form
-c ! g1 ' !
-c g = ! ' g2 !
-c ! 0 ' !
-c with g2 a n7 x (k+1) matrix and g1 a n11 x n11 upper triangular
-c matrix of bandwidth k+2. ( n11 = n7-k-1)
- pinv = one/p
-c store matrix a into g
- do 358 i=1,nc
- c(i) = z(i)
- 358 continue
- do 360 i=1,n7
- g1(i,k1) = a1(i,k1)
- g1(i,k2) = 0.
- g2(i,1) = 0.
- do 360 j=1,k
- g1(i,j) = a1(i,j)
- g2(i,j+1) = a2(i,j)
- 360 continue
- l = n10
- do 370 j=1,k1
- if(l.le.0) go to 375
- g2(l,1) = a1(l,j)
- l = l-1
- 370 continue
- 375 do 540 it=1,n8
-c fetch a new row of matrix b and store it in the arrays h1 (the part
-c with respect to g1) and h2 (the part with respect to g2).
- do 380 j=1,idim
- xi(j) = 0.
- 380 continue
- do 385 i=1,k1
- h1(i) = 0.
- h2(i) = 0.
- 385 continue
- h1(k2) = 0.
- if(it.gt.n11) go to 420
- l = it
- l0 = it
- do 390 j=1,k2
- if(l0.eq.n10) go to 400
- h1(j) = b(it,j)*pinv
- l0 = l0+1
- 390 continue
- go to 470
- 400 l0 = 1
- do 410 l1=j,k2
- h2(l0) = b(it,l1)*pinv
- l0 = l0+1
- 410 continue
- go to 470
- 420 l = 1
- i = it-n10
- do 460 j=1,k2
- i = i+1
- l0 = i
- 430 l1 = l0-k1
- if(l1.le.0) go to 450
- if(l1.le.n11) go to 440
- l0 = l1-n11
- go to 430
- 440 h1(l1) = b(it,j)*pinv
- go to 460
- 450 h2(l0) = h2(l0)+b(it,j)*pinv
- 460 continue
- if(n11.le.0) go to 510
-c rotate this row into triangle by givens transformations
-c rotation with the rows l,l+1,...n11.
- 470 do 500 j=l,n11
- piv = h1(1)
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,g1(j,1),cos,sin)
-c transformation to right hand side.
- j1 = j
- do 475 j2=1,idim
- call fprota(cos,sin,xi(j2),c(j1))
- j1 = j1+n
- 475 continue
-c transformation to the left hand side with respect to g2.
- do 480 i=1,k1
- call fprota(cos,sin,h2(i),g2(j,i))
- 480 continue
- if(j.eq.n11) go to 510
- i2 = min0(n11-j,k1)
-c transformation to the left hand side with respect to g1.
- do 490 i=1,i2
- i1 = i+1
- call fprota(cos,sin,h1(i1),g1(j,i1))
- h1(i) = h1(i1)
- 490 continue
- h1(i1) = 0.
- 500 continue
-c rotation with the rows n11+1,...n7
- 510 do 530 j=1,k1
- ij = n11+j
- if(ij.le.0) go to 530
- piv = h2(j)
-c calculate the parameters of the givens transformation
- call fpgivs(piv,g2(ij,j),cos,sin)
-c transformation to the right hand side.
- j1 = ij
- do 515 j2=1,idim
- call fprota(cos,sin,xi(j2),c(j1))
- j1 = j1+n
- 515 continue
- if(j.eq.k1) go to 540
- j1 = j+1
-c transformation to the left hand side.
- do 520 i=j1,k1
- call fprota(cos,sin,h2(i),g2(ij,i))
- 520 continue
- 530 continue
- 540 continue
-c backward substitution to obtain the b-spline coefficients
- j1 = 1
- do 542 j2=1,idim
- call fpbacp(g1,g2,c(j1),n7,k1,c(j1),k2,nest)
- j1 = j1+n
- 542 continue
-c calculate from condition (**) the remaining b-spline coefficients.
- do 547 i=1,k
- j1 = i
- do 545 j=1,idim
- j2 = j1+n7
- c(j2) = c(j1)
- j1 = j1+n
- 545 continue
- 547 continue
-c computation of f(p).
- fp = 0.
- l = k1
- jj = 0
- do 570 it=1,m1
- if(u(it).lt.t(l)) go to 550
- l = l+1
- 550 l0 = l-k2
- term = 0.
- do 565 j2=1,idim
- fac = 0.
- j1 = l0
- do 560 j=1,k1
- j1 = j1+1
- fac = fac+c(j1)*q(it,j)
- 560 continue
- jj = jj+1
- term = term+(fac-x(jj))**2
- l0 = l0+n
- 565 continue
- fp = fp+term*w(it)**2
- 570 continue
-c test whether the approximation sp(u) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 660
-c test whether the maximal number of iterations is reached.
- if(iter.eq.maxit) go to 600
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 580
- if((f2-f3) .gt. acc) go to 575
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 +p2*con1
- go to 595
- 575 if(f2.lt.0.) ich3 = 1
- 580 if(ich1.ne.0) go to 590
- if((f1-f2) .gt. acc) go to 585
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 595
- if(p.ge.p3) p = p2*con1 +p3*con9
- go to 595
- 585 if(f2.gt.0.) ich1 = 1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 590 if(f2.ge.f1 .or. f2.le.f3) go to 610
-c find the new value for p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 595 continue
-c error codes and messages.
- 600 ier = 3
- go to 660
- 610 ier = 2
- go to 660
- 620 ier = 1
- go to 660
- 630 ier = -1
- go to 660
- 640 ier = -2
-c the point (z(1),z(2),...,z(idim)) is a solution of our problem.
-c a constant function is a spline of degree k with all b-spline
-c coefficients equal to that constant.
- do 650 i=1,k1
- rn = k1-i
- t(i) = u(1)-rn*per
- j = i+k1
- rn = i-1
- t(j) = u(m)+rn*per
- 650 continue
- n = nmin
- j1 = 0
- do 658 j=1,idim
- fac = z(j)
- j2 = j1
- do 654 i=1,k1
- j2 = j2+1
- c(j2) = fac
- 654 continue
- j1 = j1+n
- 658 continue
- fp = fp0
- fpint(n) = fp0
- fpint(n-1) = 0.
- nrdata(n) = 0
- 660 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcoco.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcoco.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcoco.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,168 +0,0 @@
- subroutine fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx,
- * bind,e,wrk,lwrk,iwrk,kwrk,ier)
-c ..scalar arguments..
- real*8 s,sq
- integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier
-c ..array arguments..
- integer iwrk(kwrk)
- real*8 x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),e(nest),wrk(lwrk)
- *
- logical bind(nest)
-c ..local scalars..
- integer i,ia,ib,ic,iq,iu,iz,izz,i1,j,k,l,l1,m1,nmax,nr,n4,n6,n8,
- * ji,jib,jjb,jl,jr,ju,mb,nm
- real*8 sql,sqmax,term,tj,xi,half
-c ..subroutine references..
-c fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno
-c ..
-c set constant
- half = 0.5e0
-c determine the maximal admissible number of knots.
- nmax = m+4
-c the initial choice of knots depends on the value of iopt.
-c if iopt=0 the program starts with the minimal number of knots
-c so that can be guarantied that the concavity/convexity constraints
-c will be satisfied.
-c if iopt = 1 the program will continue from the point on where she
-c left at the foregoing call.
- if(iopt.gt.0) go to 80
-c find the minimal number of knots.
-c a knot is located at the data point x(i), i=2,3,...m-1 if
-c 1) v(i) ^= 0 and
-c 2) v(i)*v(i-1) <= 0 or v(i)*v(i+1) <= 0.
- m1 = m-1
- n = 4
- do 20 i=2,m1
- if(v(i).eq.0. .or. (v(i)*v(i-1).gt.0. .and.
- * v(i)*v(i+1).gt.0.)) go to 20
- n = n+1
-c test whether the required storage space exceeds the available one.
- if(n+4.gt.nest) go to 200
- t(n) = x(i)
- 20 continue
-c find the position of the knots t(1),...t(4) and t(n-3),...t(n) which
-c are needed for the b-spline representation of s(x).
- do 30 i=1,4
- t(i) = x(1)
- n = n+1
- t(n) = x(m)
- 30 continue
-c test whether the minimum number of knots exceeds the maximum number.
- if(n.gt.nmax) go to 210
-c main loop for the different sets of knots.
-c find corresponding values e(j) to the knots t(j+3),j=1,2,...n-6
-c e(j) will take the value -1,1, or 0 according to the requirement
-c that s(x) must be locally convex or concave at t(j+3) or that the
-c sign of s''(x) is unrestricted at that point.
- 40 i= 1
- xi = x(1)
- j = 4
- tj = t(4)
- n6 = n-6
- do 70 l=1,n6
- 50 if(xi.eq.tj) go to 60
- i = i+1
- xi = x(i)
- go to 50
- 60 e(l) = v(i)
- j = j+1
- tj = t(j)
- 70 continue
-c we partition the working space
- nm = n+maxbin
- mb = maxbin+1
- ia = 1
- ib = ia+4*n
- ic = ib+nm*maxbin
- iz = ic+n
- izz = iz+n
- iu = izz+n
- iq = iu+maxbin
- ji = 1
- ju = ji+maxtr
- jl = ju+maxtr
- jr = jl+maxtr
- jjb = jr+maxtr
- jib = jjb+mb
-c given the set of knots t(j),j=1,2,...n, find the least-squares cubic
-c spline which satisfies the imposed concavity/convexity constraints.
- call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia),
- *
- * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji),
- * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier)
-c if sq <= s or in case of abnormal exit from fpcosp, control is
-c repassed to the driver program.
- if(sq.le.s .or. ier.gt.0) go to 300
-c calculate for each knot interval t(l-1) <= xi <= t(l) the
-c sum((wi*(yi-s(xi)))**2).
-c find the interval t(k-1) <= x <= t(k) for which this sum is maximal
-c on the condition that this interval contains at least one interior
-c data point x(nr) and that s(x) is not given there by a straight line.
- 80 sqmax = 0.
- sql = 0.
- l = 5
- nr = 0
- i1 = 1
- n4 = n-4
- do 110 i=1,m
- term = (w(i)*(sx(i)-y(i)))**2
- if(x(i).lt.t(l) .or. l.gt.n4) go to 100
- term = term*half
- sql = sql+term
- if(i-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 90
- if(sql.le.sqmax) go to 90
- k = l
- sqmax = sql
- nr = i1+(i-i1)/2
- 90 l = l+1
- i1 = i
- sql = 0.
- 100 sql = sql+term
- 110 continue
- if(m-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 120
- if(sql.le.sqmax) go to 120
- k = l
- nr = i1+(m-i1)/2
-c if no such interval is found, control is repassed to the driver
-c program (ier = -1).
- 120 if(nr.eq.0) go to 190
-c if s(x) is given by the same straight line in two succeeding knot
-c intervals t(l-1) <= x <= t(l) and t(l) <= x <= t(l+1),delete t(l)
- n8 = n-8
- l1 = 0
- if(n8.le.0) go to 150
- do 140 i=1,n8
- if(.not. (bind(i).and.bind(i+1).and.bind(i+2))) go to 140
- l = i+4-l1
- if(k.gt.l) k = k-1
- n = n-1
- l1 = l1+1
- do 130 j=l,n
- t(j) = t(j+1)
- 130 continue
- 140 continue
-c test whether we cannot further increase the number of knots.
- 150 if(n.eq.nmax) go to 180
- if(n.eq.nest) go to 170
-c locate an additional knot at the point x(nr).
- j = n
- do 160 i=k,n
- t(j+1) = t(j)
- j = j-1
- 160 continue
- t(k) = x(nr)
- n = n+1
-c restart the computations with the new set of knots.
- go to 40
-c error codes and messages.
- 170 ier = -3
- go to 300
- 180 ier = -2
- go to 300
- 190 ier = -1
- go to 300
- 200 ier = 4
- go to 300
- 210 ier = 5
- 300 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcons.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcons.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcons.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,442 +0,0 @@
- subroutine fpcons(iopt,idim,m,u,mx,x,w,ib,ie,k,s,nest,tol,maxit,
- * k1,k2,n,t,nc,c,fp,fpint,z,a,b,g,q,nrdata,ier)
-c ..
-c ..scalar arguments..
- real*8 s,tol,fp
- integer iopt,idim,m,mx,ib,ie,k,nest,maxit,k1,k2,n,nc,ier
-c ..array arguments..
- real*8 u(m),x(mx),w(m),t(nest),c(nc),fpint(nest),
- * z(nc),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1)
- integer nrdata(nest)
-c ..local scalars..
- real*8 acc,con1,con4,con9,cos,fac,fpart,fpms,fpold,fp0,f1,f2,f3,
- * half,one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,ui,wi
- integer i,ich1,ich3,it,iter,i1,i2,i3,j,jb,je,jj,j1,j2,j3,kbe,
- * l,li,lj,l0,mb,me,mm,new,nk1,nmax,nmin,nn,nplus,npl1,nrint,n8
-c ..local arrays..
- real*8 h(7),xi(10)
-c ..function references
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota
-c ..
-c set constants
- one = 0.1e+01
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- half = 0.5e0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position c
-c ************************************************************** c
-c given a set of knots we compute the least-squares curve sinf(u), c
-c and the corresponding sum of squared residuals fp=f(p=inf). c
-c if iopt=-1 sinf(u) is the requested curve. c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares curve until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmax = m+k+1-max(0,ib-1)-max(0,ie-1) c
-c if s > 0 and c
-c iopt=0 we first compute the least-squares polynomial curve of c
-c degree k; n = nmin = 2*k+2 c
-c iopt=1 we start with the set of knots found at the last c
-c call of the routine, except for the case that s > fp0; then c
-c we compute directly the polynomial curve of degree k. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c determine nmin, the number of knots for polynomial approximation.
- nmin = 2*k1
-c find which data points are to be concidered.
- mb = 2
- jb = ib
- if(ib.gt.0) go to 10
- mb = 1
- jb = 1
- 10 me = m-1
- je = ie
- if(ie.gt.0) go to 20
- me = m
- je = 1
- 20 if(iopt.lt.0) go to 60
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c determine nmax, the number of knots for spline interpolation.
- kbe = k1-jb-je
- mmin = kbe+2
- mm = m-mmin
- nmax = nmin+mm
- if(s.gt.0.) go to 40
-c if s=0, s(u) is an interpolating curve.
-c test whether the required storage space exceeds the available one.
- n = nmax
- if(nmax.gt.nest) go to 420
-c find the position of the interior knots in case of interpolation.
- if(mm.eq.0) go to 60
- 25 i = k2
- j = 3-jb+k/2
- do 30 l=1,mm
- t(i) = u(j)
- i = i+1
- j = j+1
- 30 continue
- go to 60
-c if s>0 our initial choice of knots depends on the value of iopt.
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c polynomial curve which is a spline curve without interior knots.
-c if iopt=1 and fp0>s we start computing the least squares spline curve
-c according to the set of knots found at the last call of the routine.
- 40 if(iopt.eq.0) go to 50
- if(n.eq.nmin) go to 50
- fp0 = fpint(n)
- fpold = fpint(n-1)
- nplus = nrdata(n)
- if(fp0.gt.s) go to 60
- 50 n = nmin
- fpold = 0.
- nplus = 0
- nrdata(1) = m-2
-c main loop for the different sets of knots. m is a save upper bound
-c for the number of trials.
- 60 do 200 iter = 1,m
- if(n.eq.nmin) ier = -2
-c find nrint, tne number of knot intervals.
- nrint = n-nmin+1
-c find the position of the additional knots which are needed for
-c the b-spline representation of s(u).
- nk1 = n-k1
- i = n
- do 70 j=1,k1
- t(j) = u(1)
- t(i) = u(m)
- i = i-1
- 70 continue
-c compute the b-spline coefficients of the least-squares spline curve
-c sinf(u). the observation matrix a is built up row by row and
-c reduced to upper triangular form by givens transformations.
-c at the same time fp=f(p=inf) is computed.
- fp = 0.
-c nn denotes the dimension of the splines
- nn = nk1-ib-ie
-c initialize the b-spline coefficients and the observation matrix a.
- do 75 i=1,nc
- z(i) = 0.
- c(i) = 0.
- 75 continue
- if(me.lt.mb) go to 134
- if(nn.eq.0) go to 82
- do 80 i=1,nn
- do 80 j=1,k1
- a(i,j) = 0.
- 80 continue
- 82 l = k1
- jj = (mb-1)*idim
- do 130 it=mb,me
-c fetch the current data point u(it),x(it).
- ui = u(it)
- wi = w(it)
- do 84 j=1,idim
- jj = jj+1
- xi(j) = x(jj)*wi
- 84 continue
-c search for knot interval t(l) <= ui < t(l+1).
- 86 if(ui.lt.t(l+1) .or. l.eq.nk1) go to 90
- l = l+1
- go to 86
-c evaluate the (k+1) non-zero b-splines at ui and store them in q.
- 90 call fpbspl(t,n,k,ui,l,h)
- do 92 i=1,k1
- q(it,i) = h(i)
- h(i) = h(i)*wi
- 92 continue
-c take into account that certain b-spline coefficients must be zero.
- lj = k1
- j = nk1-l-ie
- if(j.ge.0) go to 94
- lj = lj+j
- 94 li = 1
- j = l-k1-ib
- if(j.ge.0) go to 96
- li = li-j
- j = 0
- 96 if(li.gt.lj) go to 120
-c rotate the new row of the observation matrix into triangle.
- do 110 i=li,lj
- j = j+1
- piv = h(i)
- if(piv.eq.0.) go to 110
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(j,1),cos,sin)
-c transformations to right hand side.
- j1 = j
- do 98 j2 =1,idim
- call fprota(cos,sin,xi(j2),z(j1))
- j1 = j1+n
- 98 continue
- if(i.eq.lj) go to 120
- i2 = 1
- i3 = i+1
- do 100 i1 = i3,lj
- i2 = i2+1
-c transformations to left hand side.
- call fprota(cos,sin,h(i1),a(j,i2))
- 100 continue
- 110 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 120 do 125 j2=1,idim
- fp = fp+xi(j2)**2
- 125 continue
- 130 continue
- if(ier.eq.(-2)) fp0 = fp
- fpint(n) = fp0
- fpint(n-1) = fpold
- nrdata(n) = nplus
-c backward substitution to obtain the b-spline coefficients.
- if(nn.eq.0) go to 134
- j1 = 1
- do 132 j2=1,idim
- j3 = j1+ib
- call fpback(a,z(j1),nn,k1,c(j3),nest)
- j1 = j1+n
- 132 continue
-c test whether the approximation sinf(u) is an acceptable solution.
- 134 if(iopt.lt.0) go to 440
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c if f(p=inf) < s accept the choice of knots.
- if(fpms.lt.0.) go to 250
-c if n = nmax, sinf(u) is an interpolating spline curve.
- if(n.eq.nmax) go to 430
-c increase the number of knots.
-c if n=nest we cannot increase the number of knots because of
-c the storage capacity limitation.
- if(n.eq.nest) go to 420
-c determine the number of knots nplus we are going to add.
- if(ier.eq.0) go to 140
- nplus = 1
- ier = 0
- go to 150
- 140 npl1 = nplus*2
- rn = nplus
- if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp)
- nplus = min0(nplus*2,max0(npl1,nplus/2,1))
- 150 fpold = fp
-c compute the sum of squared residuals for each knot interval
-c t(j+k) <= u(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint.
- fpart = 0.
- i = 1
- l = k2
- new = 0
- jj = (mb-1)*idim
- do 180 it=mb,me
- if(u(it).lt.t(l) .or. l.gt.nk1) go to 160
- new = 1
- l = l+1
- 160 term = 0.
- l0 = l-k2
- do 175 j2=1,idim
- fac = 0.
- j1 = l0
- do 170 j=1,k1
- j1 = j1+1
- fac = fac+c(j1)*q(it,j)
- 170 continue
- jj = jj+1
- term = term+(w(it)*(fac-x(jj)))**2
- l0 = l0+n
- 175 continue
- fpart = fpart+term
- if(new.eq.0) go to 180
- store = term*half
- fpint(i) = fpart-store
- i = i+1
- fpart = store
- new = 0
- 180 continue
- fpint(nrint) = fpart
- do 190 l=1,nplus
-c add a new knot.
- call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1)
-c if n=nmax we locate the knots as for interpolation
- if(n.eq.nmax) go to 25
-c test whether we cannot further increase the number of knots.
- if(n.eq.nest) go to 200
- 190 continue
-c restart the computations with the new set of knots.
- 200 continue
-c test whether the least-squares kth degree polynomial curve is a
-c solution of our approximation problem.
- 250 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline curve sp(u). c
-c ********************************************************** c
-c we have determined the number of knots and their position. c
-c we now compute the b-spline coefficients of the smoothing curve c
-c sp(u). the observation matrix a is extended by the rows of matrix c
-c b expressing that the kth derivative discontinuities of sp(u) at c
-c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c
-c ponding weights of these additional rows are set to 1/p. c
-c iteratively we then have to determine the value of p such that f(p),c
-c the sum of squared residuals be = s. we already know that the least c
-c squares kth degree polynomial curve corresponds to p=0, and that c
-c the least-squares spline curve corresponds to p=infinity. the c
-c iteration process which is proposed here, makes use of rational c
-c interpolation. since f(p) is a convex and strictly decreasing c
-c function of p, it can be approximated by a rational function c
-c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c
-c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c
-c to calculate the new value of p such that r(p)=s. convergence is c
-c guaranteed by taking f1>0 and f3<0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jump of the kth derivative of the
-c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b.
- call fpdisc(t,n,k2,b,nest)
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = 0.
- do 252 i=1,nn
- p = p+a(i,1)
- 252 continue
- rn = nn
- p = rn/p
- ich1 = 0
- ich3 = 0
- n8 = n-nmin
-c iteration process to find the root of f(p) = s.
- do 360 iter=1,maxit
-c the rows of matrix b with weight 1/p are rotated into the
-c triangularised observation matrix a which is stored in g.
- pinv = one/p
- do 255 i=1,nc
- c(i) = z(i)
- 255 continue
- do 260 i=1,nn
- g(i,k2) = 0.
- do 260 j=1,k1
- g(i,j) = a(i,j)
- 260 continue
- do 300 it=1,n8
-c the row of matrix b is rotated into triangle by givens transformation
- do 264 i=1,k2
- h(i) = b(it,i)*pinv
- 264 continue
- do 268 j=1,idim
- xi(j) = 0.
- 268 continue
-c take into account that certain b-spline coefficients must be zero.
- if(it.gt.ib) go to 274
- j1 = ib-it+2
- j2 = 1
- do 270 i=j1,k2
- h(j2) = h(i)
- j2 = j2+1
- 270 continue
- do 272 i=j2,k2
- h(i) = 0.
- 272 continue
- 274 jj = max0(1,it-ib)
- do 290 j=jj,nn
- piv = h(1)
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,g(j,1),cos,sin)
-c transformations to right hand side.
- j1 = j
- do 277 j2=1,idim
- call fprota(cos,sin,xi(j2),c(j1))
- j1 = j1+n
- 277 continue
- if(j.eq.nn) go to 300
- i2 = min0(nn-j,k1)
- do 280 i=1,i2
-c transformations to left hand side.
- i1 = i+1
- call fprota(cos,sin,h(i1),g(j,i1))
- h(i) = h(i1)
- 280 continue
- h(i2+1) = 0.
- 290 continue
- 300 continue
-c backward substitution to obtain the b-spline coefficients.
- j1 = 1
- do 308 j2=1,idim
- j3 = j1+ib
- call fpback(g,c(j1),nn,k2,c(j3),nest)
- if(ib.eq.0) go to 306
- j3 = j1
- do 304 i=1,ib
- c(j3) = 0.
- j3 = j3+1
- 304 continue
- 306 j1 =j1+n
- 308 continue
-c computation of f(p).
- fp = 0.
- l = k2
- jj = (mb-1)*idim
- do 330 it=mb,me
- if(u(it).lt.t(l) .or. l.gt.nk1) go to 310
- l = l+1
- 310 l0 = l-k2
- term = 0.
- do 325 j2=1,idim
- fac = 0.
- j1 = l0
- do 320 j=1,k1
- j1 = j1+1
- fac = fac+c(j1)*q(it,j)
- 320 continue
- jj = jj+1
- term = term+(fac-x(jj))**2
- l0 = l0+n
- 325 continue
- fp = fp+term*w(it)**2
- 330 continue
-c test whether the approximation sp(u) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximal number of iterations is reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 340
- if((f2-f3).gt.acc) go to 335
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p=p1*con9 + p2*con1
- go to 360
- 335 if(f2.lt.0.) ich3=1
- 340 if(ich1.ne.0) go to 350
- if((f1-f2).gt.acc) go to 345
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 360
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 360
- 345 if(f2.gt.0.) ich1=1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 350 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value for p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 360 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- 440 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcosp.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcosp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcosp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,362 +0,0 @@
- subroutine fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,a,
- *
- * b,const,z,zz,u,q,info,up,left,right,jbind,ibind,ier)
-c ..
-c ..scalar arguments..
- real*8 sq
- integer m,n,maxtr,maxbin,nm,mb,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),t(n),e(n),c(n),sx(m),a(n,4),b(nm,maxbin),
- * const(n),z(n),zz(n),u(maxbin),q(m,4)
- integer info(maxtr),up(maxtr),left(maxtr),right(maxtr),jbind(mb),
- * ibind(mb)
- logical bind(n)
-c ..local scalars..
- integer count,i,i1,j,j1,j2,j3,k,kdim,k1,k2,k3,k4,k5,k6,
- * l,lp1,l1,l2,l3,merk,nbind,number,n1,n4,n6
- real*8 f,wi,xi
-c ..local array..
- real*8 h(4)
-c ..subroutine references..
-c fpbspl,fpadno,fpdeno,fpfrno,fpseno
-c ..
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c if we use the b-spline representation of s(x) our approximation c
-c problem results in a quadratic programming problem: c
-c find the b-spline coefficients c(j),j=1,2,...n-4 such that c
-c (1) sumi((wi*(yi-sumj(cj*nj(xi))))**2),i=1,2,...m is minimal c
-c (2) sumj(cj*n''j(t(l+3)))*e(l) <= 0, l=1,2,...n-6. c
-c to solve this problem we use the theil-van de panne procedure. c
-c if the inequality constraints (2) are numbered from 1 to n-6, c
-c this algorithm finds a subset of constraints ibind(1)..ibind(nbind) c
-c such that the solution of the minimization problem (1) with these c
-c constraints in equality form, satisfies all constraints. such a c
-c feasible solution is optimal if the lagrange parameters associated c
-c with that problem with equality constraints, are all positive. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c determine n6, the number of inequality constraints.
- n6 = n-6
-c fix the parameters which determine these constraints.
- do 10 i=1,n6
- const(i) = e(i)*(t(i+4)-t(i+1))/(t(i+5)-t(i+2))
- 10 continue
-c initialize the triply linked tree which is used to find the subset
-c of constraints ibind(1),...ibind(nbind).
- count = 1
- info(1) = 0
- left(1) = 0
- right(1) = 0
- up(1) = 1
- merk = 1
-c set up the normal equations n'nc=n'y where n denotes the m x (n-4)
-c observation matrix with elements ni,j = wi*nj(xi) and y is the
-c column vector with elements yi*wi.
-c from the properties of the b-splines nj(x),j=1,2,...n-4, it follows
-c that n'n is a (n-4) x (n-4) positive definit bandmatrix of
-c bandwidth 7. the matrices n'n and n'y are built up in a and z.
- n4 = n-4
-c initialization
- do 20 i=1,n4
- z(i) = 0.
- do 20 j=1,4
- a(i,j) = 0.
- 20 continue
- l = 4
- lp1 = l+1
- do 70 i=1,m
-c fetch the current row of the observation matrix.
- xi = x(i)
- wi = w(i)**2
-c search for knot interval t(l) <= xi < t(l+1)
- 30 if(xi.lt.t(lp1) .or. l.eq.n4) go to 40
- l = lp1
- lp1 = l+1
- go to 30
-c evaluate the four non-zero cubic b-splines nj(xi),j=l-3,...l.
- 40 call fpbspl(t,n,3,xi,l,h)
-c store in q these values h(1),h(2),...h(4).
- do 50 j=1,4
- q(i,j) = h(j)
- 50 continue
-c add the contribution of the current row of the observation matrix
-c n to the normal equations.
- l3 = l-3
- k1 = 0
- do 60 j1 = l3,l
- k1 = k1+1
- f = h(k1)
- z(j1) = z(j1)+f*wi*y(i)
- k2 = k1
- j2 = 4
- do 60 j3 = j1,l
- a(j3,j2) = a(j3,j2)+f*wi*h(k2)
- k2 = k2+1
- j2 = j2-1
- 60 continue
- 70 continue
-c since n'n is a symmetric matrix it can be factorized as
-c (3) n'n = (r1)'(d1)(r1)
-c with d1 a diagonal matrix and r1 an (n-4) x (n-4) unit upper
-c triangular matrix of bandwidth 4. the matrices r1 and d1 are built
-c up in a. at the same time we solve the systems of equations
-c (4) (r1)'(z2) = n'y
-c (5) (d1) (z1) = (z2)
-c the vectors z2 and z1 are kept in zz and z.
- do 140 i=1,n4
- k1 = 1
- if(i.lt.4) k1 = 5-i
- k2 = i-4+k1
- k3 = k2
- do 100 j=k1,4
- k4 = j-1
- k5 = 4-j+k1
- f = a(i,j)
- if(k1.gt.k4) go to 90
- k6 = k2
- do 80 k=k1,k4
- f = f-a(i,k)*a(k3,k5)*a(k6,4)
- k5 = k5+1
- k6 = k6+1
- 80 continue
- 90 if(j.eq.4) go to 110
- a(i,j) = f/a(k3,4)
- k3 = k3+1
- 100 continue
- 110 a(i,4) = f
- f = z(i)
- if(i.eq.1) go to 130
- k4 = i
- do 120 j=k1,3
- k = k1+3-j
- k4 = k4-1
- f = f-a(i,k)*z(k4)*a(k4,4)
- 120 continue
- 130 z(i) = f/a(i,4)
- zz(i) = f
- 140 continue
-c start computing the least-squares cubic spline without taking account
-c of any constraint.
- nbind = 0
- n1 = 1
- ibind(1) = 0
-c main loop for the least-squares problems with different subsets of
-c the constraints (2) in equality form. the resulting b-spline coeff.
-c c and lagrange parameters u are the solution of the system
-c ! n'n b' ! ! c ! ! n'y !
-c (6) ! ! ! ! = ! !
-c ! b 0 ! ! u ! ! 0 !
-c z1 is stored into array c.
- 150 do 160 i=1,n4
- c(i) = z(i)
- 160 continue
-c if there are no equality constraints, compute the coeff. c directly.
- if(nbind.eq.0) go to 370
-c initialization
- kdim = n4+nbind
- do 170 i=1,nbind
- do 170 j=1,kdim
- b(j,i) = 0.
- 170 continue
-c matrix b is built up,expressing that the constraints nrs ibind(1),...
-c ibind(nbind) must be satisfied in equality form.
- do 180 i=1,nbind
- l = ibind(i)
- b(l,i) = e(l)
- b(l+1,i) = -(e(l)+const(l))
- b(l+2,i) = const(l)
- 180 continue
-c find the matrix (b1) as the solution of the system of equations
-c (7) (r1)'(d1)(b1) = b'
-c (b1) is built up in the upper part of the array b(rows 1,...n-4).
- do 220 k1=1,nbind
- l = ibind(k1)
- do 210 i=l,n4
- f = b(i,k1)
- if(i.eq.1) go to 200
- k2 = 3
- if(i.lt.4) k2 = i-1
- do 190 k3=1,k2
- l1 = i-k3
- l2 = 4-k3
- f = f-b(l1,k1)*a(i,l2)*a(l1,4)
- 190 continue
- 200 b(i,k1) = f/a(i,4)
- 210 continue
- 220 continue
-c factorization of the symmetric matrix -(b1)'(d1)(b1)
-c (8) -(b1)'(d1)(b1) = (r2)'(d2)(r2)
-c with (d2) a diagonal matrix and (r2) an nbind x nbind unit upper
-c triangular matrix. the matrices r2 and d2 are built up in the lower
-c part of the array b (rows n-3,n-2,...n-4+nbind).
- do 270 i=1,nbind
- i1 = i-1
- do 260 j=i,nbind
- f = 0.
- do 230 k=1,n4
- f = f+b(k,i)*b(k,j)*a(k,4)
- 230 continue
- k1 = n4+1
- if(i1.eq.0) go to 250
- do 240 k=1,i1
- f = f+b(k1,i)*b(k1,j)*b(k1,k)
- k1 = k1+1
- 240 continue
- 250 b(k1,j) = -f
- if(j.eq.i) go to 260
- b(k1,j) = b(k1,j)/b(k1,i)
- 260 continue
- 270 continue
-c according to (3),(7) and (8) the system of equations (6) becomes
-c ! (r1)' 0 ! ! (d1) 0 ! ! (r1) (b1) ! ! c ! ! n'y !
-c (9) ! ! ! ! ! ! ! ! = ! !
-c ! (b1)' (r2)'! ! 0 (d2) ! ! 0 (r2) ! ! u ! ! 0 !
-c backward substitution to obtain the b-spline coefficients c(j),j=1,..
-c n-4 and the lagrange parameters u(j),j=1,2,...nbind.
-c first step of the backward substitution: solve the system
-c ! (r1)'(d1) 0 ! ! (c1) ! ! n'y !
-c (10) ! ! ! ! = ! !
-c ! (b1)'(d1) (r2)'(d2) ! ! (u1) ! ! 0 !
-c from (4) and (5) we know that this is equivalent to
-c (11) (c1) = (z1)
-c (12) (r2)'(d2)(u1) = -(b1)'(z2)
- do 310 i=1,nbind
- f = 0.
- do 280 j=1,n4
- f = f+b(j,i)*zz(j)
- 280 continue
- i1 = i-1
- k1 = n4+1
- if(i1.eq.0) go to 300
- do 290 j=1,i1
- f = f+u(j)*b(k1,i)*b(k1,j)
- k1 = k1+1
- 290 continue
- 300 u(i) = -f/b(k1,i)
- 310 continue
-c second step of the backward substitution: solve the system
-c ! (r1) (b1) ! ! c ! ! c1 !
-c (13) ! ! ! ! = ! !
-c ! 0 (r2) ! ! u ! ! u1 !
- k1 = nbind
- k2 = kdim
-c find the lagrange parameters u.
- do 340 i=1,nbind
- f = u(k1)
- if(i.eq.1) go to 330
- k3 = k1+1
- do 320 j=k3,nbind
- f = f-u(j)*b(k2,j)
- 320 continue
- 330 u(k1) = f
- k1 = k1-1
- k2 = k2-1
- 340 continue
-c find the b-spline coefficients c.
- do 360 i=1,n4
- f = c(i)
- do 350 j=1,nbind
- f = f-u(j)*b(i,j)
- 350 continue
- c(i) = f
- 360 continue
- 370 k1 = n4
- do 390 i=2,n4
- k1 = k1-1
- f = c(k1)
- k2 = 1
- if(i.lt.5) k2 = 5-i
- k3 = k1
- l = 3
- do 380 j=k2,3
- k3 = k3+1
- f = f-a(k3,l)*c(k3)
- l = l-1
- 380 continue
- c(k1) = f
- 390 continue
-c test whether the solution of the least-squares problem with the
-c constraints ibind(1),...ibind(nbind) in equality form, satisfies
-c all of the constraints (2).
- k = 1
-c number counts the number of violated inequality constraints.
- number = 0
- do 440 j=1,n6
- l = ibind(k)
- k = k+1
- if(j.eq.l) go to 440
- k = k-1
-c test whether constraint j is satisfied
- f = e(j)*(c(j)-c(j+1))+const(j)*(c(j+2)-c(j+1))
- if(f.le.0.) go to 440
-c if constraint j is not satisfied, add a branch of length nbind+1
-c to the tree. the nodes of this branch contain in their information
-c field the number of the constraints ibind(1),...ibind(nbind) and j,
-c arranged in increasing order.
- number = number+1
- k1 = k-1
- if(k1.eq.0) go to 410
- do 400 i=1,k1
- jbind(i) = ibind(i)
- 400 continue
- 410 jbind(k) = j
- if(l.eq.0) go to 430
- do 420 i=k,nbind
- jbind(i+1) = ibind(i)
- 420 continue
- 430 call fpadno(maxtr,up,left,right,info,count,merk,jbind,n1,ier)
-c test whether the storage space which is required for the tree,exceeds
-c the available storage space.
- if(ier.ne.0) go to 560
- 440 continue
-c test whether the solution of the least-squares problem with equality
-c constraints is a feasible solution.
- if(number.eq.0) go to 470
-c test whether there are still cases with nbind constraints in
-c equality form to be considered.
- 450 if(merk.gt.1) go to 460
- nbind = n1
-c test whether the number of knots where s''(x)=0 exceeds maxbin.
- if(nbind.gt.maxbin) go to 550
- n1 = n1+1
- ibind(n1) = 0
-c search which cases with nbind constraints in equality form
-c are going to be considered.
- call fpdeno(maxtr,up,left,right,nbind,merk)
-c test whether the quadratic programming problem has a solution.
- if(merk.eq.1) go to 570
-c find a new case with nbind constraints in equality form.
- 460 call fpseno(maxtr,up,left,right,info,merk,ibind,nbind)
- go to 150
-c test whether the feasible solution is optimal.
- 470 ier = 0
- do 480 i=1,n6
- bind(i) = .false.
- 480 continue
- if(nbind.eq.0) go to 500
- do 490 i=1,nbind
- if(u(i).le.0.) go to 450
- j = ibind(i)
- bind(j) = .true.
- 490 continue
-c evaluate s(x) at the data points x(i) and calculate the weighted
-c sum of squared residual right hand sides sq.
- 500 sq = 0.
- l = 4
- lp1 = 5
- do 530 i=1,m
- 510 if(x(i).lt.t(lp1) .or. l.eq.n4) go to 520
- l = lp1
- lp1 = l+1
- go to 510
- 520 sx(i) = c(l-3)*q(i,1)+c(l-2)*q(i,2)+c(l-1)*q(i,3)+c(l)*q(i,4)
- sq = sq+(w(i)*(y(i)-sx(i)))**2
- 530 continue
- go to 600
-c error codes and messages.
- 550 ier = 1
- go to 600
- 560 ier = 2
- go to 600
- 570 ier = 3
- 600 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcsin.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcsin.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcsin.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,56 +0,0 @@
- subroutine fpcsin(a,b,par,sia,coa,sib,cob,ress,resc)
-c fpcsin calculates the integrals ress=integral((b-x)**3*sin(par*x))
-c and resc=integral((b-x)**3*cos(par*x)) over the interval (a,b),
-c given sia=sin(par*a),coa=cos(par*a),sib=sin(par*b) and cob=cos(par*b)
-c ..
-c ..scalar arguments..
- real*8 a,b,par,sia,coa,sib,cob,ress,resc
-c ..local scalars..
- integer i,j
- real*8 ab,ab4,ai,alfa,beta,b2,b4,eps,fac,f1,f2,one,quart,six,
- * three,two
-c ..function references..
- real*8 abs
-c ..
- one = 0.1e+01
- two = 0.2e+01
- three = 0.3e+01
- six = 0.6e+01
- quart = 0.25e+0
- eps = 0.1e-09
- ab = b-a
- ab4 = ab**4
- alfa = ab*par
-c the way of calculating the integrals ress and resc depends on
-c the value of alfa = (b-a)*par.
- if(abs(alfa).le.one) go to 100
-c integration by parts.
- beta = one/alfa
- b2 = beta**2
- b4 = six*b2**2
- f1 = three*b2*(one-two*b2)
- f2 = beta*(one-six*b2)
- ress = ab4*(coa*f2+sia*f1+sib*b4)
- resc = ab4*(coa*f1-sia*f2+cob*b4)
- go to 400
-c ress and resc are found by evaluating a series expansion.
- 100 fac = quart
- f1 = fac
- f2 = 0.
- i = 4
- do 200 j=1,5
- i = i+1
- ai = i
- fac = fac*alfa/ai
- f2 = f2+fac
- if(abs(fac).le.eps) go to 300
- i = i+1
- ai = i
- fac = -fac*alfa/ai
- f1 = f1+fac
- if(abs(fac).le.eps) go to 300
- 200 continue
- 300 ress = ab4*(coa*f2+sia*f1)
- resc = ab4*(coa*f1-sia*f2)
- 400 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcurf.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcurf.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcurf.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,359 +0,0 @@
- subroutine fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,
- * n,t,c,fp,fpint,z,a,b,g,q,nrdata,ier)
-c ..
-c ..scalar arguments..
- real*8 xb,xe,s,tol,fp
- integer iopt,m,k,nest,maxit,k1,k2,n,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),t(nest),c(nest),fpint(nest),
- * z(nest),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1)
- integer nrdata(nest)
-c ..local scalars..
- real*8 acc,con1,con4,con9,cos,half,fpart,fpms,fpold,fp0,f1,f2,f3,
- * one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,wi,xi,yi
- integer i,ich1,ich3,it,iter,i1,i2,i3,j,k3,l,l0,
- * mk1,new,nk1,nmax,nmin,nplus,npl1,nrint,n8
-c ..local arrays..
- real*8 h(7)
-c ..function references
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota
-c ..
-c set constants
- one = 0.1d+01
- con1 = 0.1d0
- con9 = 0.9d0
- con4 = 0.4d-01
- half = 0.5d0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position c
-c ************************************************************** c
-c given a set of knots we compute the least-squares spline sinf(x), c
-c and the corresponding sum of squared residuals fp=f(p=inf). c
-c if iopt=-1 sinf(x) is the requested approximation. c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares spline until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmax = m+k+1. c
-c if s > 0 and c
-c iopt=0 we first compute the least-squares polynomial of c
-c degree k; n = nmin = 2*k+2 c
-c iopt=1 we start with the set of knots found at the last c
-c call of the routine, except for the case that s > fp0; then c
-c we compute directly the least-squares polynomial of degree k. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c determine nmin, the number of knots for polynomial approximation.
- nmin = 2*k1
- if(iopt.lt.0) go to 60
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c determine nmax, the number of knots for spline interpolation.
- nmax = m+k1
- if(s.gt.0.0d0) go to 45
-c if s=0, s(x) is an interpolating spline.
-c test whether the required storage space exceeds the available one.
- n = nmax
- if(nmax.gt.nest) go to 420
-c find the position of the interior knots in case of interpolation.
- 10 mk1 = m-k1
- if(mk1.eq.0) go to 60
- k3 = k/2
- i = k2
- j = k3+2
- if(k3*2.eq.k) go to 30
- do 20 l=1,mk1
- t(i) = x(j)
- i = i+1
- j = j+1
- 20 continue
- go to 60
- 30 do 40 l=1,mk1
- t(i) = (x(j)+x(j-1))*half
- i = i+1
- j = j+1
- 40 continue
- go to 60
-c if s>0 our initial choice of knots depends on the value of iopt.
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c polynomial of degree k which is a spline without interior knots.
-c if iopt=1 and fp0>s we start computing the least squares spline
-c according to the set of knots found at the last call of the routine.
- 45 if(iopt.eq.0) go to 50
- if(n.eq.nmin) go to 50
- fp0 = fpint(n)
- fpold = fpint(n-1)
- nplus = nrdata(n)
- if(fp0.gt.s) go to 60
- 50 n = nmin
- fpold = 0.0d0
- nplus = 0
- nrdata(1) = m-2
-c main loop for the different sets of knots. m is a save upper bound
-c for the number of trials.
- 60 do 200 iter = 1,m
- if(n.eq.nmin) ier = -2
-c find nrint, tne number of knot intervals.
- nrint = n-nmin+1
-c find the position of the additional knots which are needed for
-c the b-spline representation of s(x).
- nk1 = n-k1
- i = n
- do 70 j=1,k1
- t(j) = xb
- t(i) = xe
- i = i-1
- 70 continue
-c compute the b-spline coefficients of the least-squares spline
-c sinf(x). the observation matrix a is built up row by row and
-c reduced to upper triangular form by givens transformations.
-c at the same time fp=f(p=inf) is computed.
- fp = 0.0d0
-c initialize the observation matrix a.
- do 80 i=1,nk1
- z(i) = 0.0d0
- do 80 j=1,k1
- a(i,j) = 0.0d0
- 80 continue
- l = k1
- do 130 it=1,m
-c fetch the current data point x(it),y(it).
- xi = x(it)
- wi = w(it)
- yi = y(it)*wi
-c search for knot interval t(l) <= xi < t(l+1).
- 85 if(xi.lt.t(l+1) .or. l.eq.nk1) go to 90
- l = l+1
- go to 85
-c evaluate the (k+1) non-zero b-splines at xi and store them in q.
- 90 call fpbspl(t,n,k,xi,l,h)
- do 95 i=1,k1
- q(it,i) = h(i)
- h(i) = h(i)*wi
- 95 continue
-c rotate the new row of the observation matrix into triangle.
- j = l-k1
- do 110 i=1,k1
- j = j+1
- piv = h(i)
- if(piv.eq.0.0d0) go to 110
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(j,1),cos,sin)
-c transformations to right hand side.
- call fprota(cos,sin,yi,z(j))
- if(i.eq.k1) go to 120
- i2 = 1
- i3 = i+1
- do 100 i1 = i3,k1
- i2 = i2+1
-c transformations to left hand side.
- call fprota(cos,sin,h(i1),a(j,i2))
- 100 continue
- 110 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 120 fp = fp+yi*yi
- 130 continue
- if(ier.eq.(-2)) fp0 = fp
- fpint(n) = fp0
- fpint(n-1) = fpold
- nrdata(n) = nplus
-c backward substitution to obtain the b-spline coefficients.
- call fpback(a,z,nk1,k1,c,nest)
-c test whether the approximation sinf(x) is an acceptable solution.
- if(iopt.lt.0) go to 440
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c if f(p=inf) < s accept the choice of knots.
- if(fpms.lt.0.0d0) go to 250
-c if n = nmax, sinf(x) is an interpolating spline.
- if(n.eq.nmax) go to 430
-c increase the number of knots.
-c if n=nest we cannot increase the number of knots because of
-c the storage capacity limitation.
- if(n.eq.nest) go to 420
-c determine the number of knots nplus we are going to add.
- if(ier.eq.0) go to 140
- nplus = 1
- ier = 0
- go to 150
- 140 npl1 = nplus*2
- rn = nplus
- if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp)
- nplus = min0(nplus*2,max0(npl1,nplus/2,1))
- 150 fpold = fp
-c compute the sum((w(i)*(y(i)-s(x(i))))**2) for each knot interval
-c t(j+k) <= x(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint.
- fpart = 0.0d0
- i = 1
- l = k2
- new = 0
- do 180 it=1,m
- if(x(it).lt.t(l) .or. l.gt.nk1) go to 160
- new = 1
- l = l+1
- 160 term = 0.0d0
- l0 = l-k2
- do 170 j=1,k1
- l0 = l0+1
- term = term+c(l0)*q(it,j)
- 170 continue
- term = (w(it)*(term-y(it)))**2
- fpart = fpart+term
- if(new.eq.0) go to 180
- store = term*half
- fpint(i) = fpart-store
- i = i+1
- fpart = store
- new = 0
- 180 continue
- fpint(nrint) = fpart
- do 190 l=1,nplus
-c add a new knot.
- call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1)
-c if n=nmax we locate the knots as for interpolation.
- if(n.eq.nmax) go to 10
-c test whether we cannot further increase the number of knots.
- if(n.eq.nest) go to 200
- 190 continue
-c restart the computations with the new set of knots.
- 200 continue
-c test whether the least-squares kth degree polynomial is a solution
-c of our approximation problem.
- 250 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline sp(x). c
-c *************************************************** c
-c we have determined the number of knots and their position. c
-c we now compute the b-spline coefficients of the smoothing spline c
-c sp(x). the observation matrix a is extended by the rows of matrix c
-c b expressing that the kth derivative discontinuities of sp(x) at c
-c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c
-c ponding weights of these additional rows are set to 1/p. c
-c iteratively we then have to determine the value of p such that c
-c f(p)=sum((w(i)*(y(i)-sp(x(i))))**2) be = s. we already know that c
-c the least-squares kth degree polynomial corresponds to p=0, and c
-c that the least-squares spline corresponds to p=infinity. the c
-c iteration process which is proposed here, makes use of rational c
-c interpolation. since f(p) is a convex and strictly decreasing c
-c function of p, it can be approximated by a rational function c
-c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c
-c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c
-c to calculate the new value of p such that r(p)=s. convergence is c
-c guaranteed by taking f1>0 and f3<0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jump of the kth derivative of the
-c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b.
- call fpdisc(t,n,k2,b,nest)
-c initial value for p.
- p1 = 0.0d0
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = 0.
- do 255 i=1,nk1
- p = p+a(i,1)
- 255 continue
- rn = nk1
- p = rn/p
- ich1 = 0
- ich3 = 0
- n8 = n-nmin
-c iteration process to find the root of f(p) = s.
- do 360 iter=1,maxit
-c the rows of matrix b with weight 1/p are rotated into the
-c triangularised observation matrix a which is stored in g.
- pinv = one/p
- do 260 i=1,nk1
- c(i) = z(i)
- g(i,k2) = 0.0d0
- do 260 j=1,k1
- g(i,j) = a(i,j)
- 260 continue
- do 300 it=1,n8
-c the row of matrix b is rotated into triangle by givens transformation
- do 270 i=1,k2
- h(i) = b(it,i)*pinv
- 270 continue
- yi = 0.0d0
- do 290 j=it,nk1
- piv = h(1)
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,g(j,1),cos,sin)
-c transformations to right hand side.
- call fprota(cos,sin,yi,c(j))
- if(j.eq.nk1) go to 300
- i2 = k1
- if(j.gt.n8) i2 = nk1-j
- do 280 i=1,i2
-c transformations to left hand side.
- i1 = i+1
- call fprota(cos,sin,h(i1),g(j,i1))
- h(i) = h(i1)
- 280 continue
- h(i2+1) = 0.0d0
- 290 continue
- 300 continue
-c backward substitution to obtain the b-spline coefficients.
- call fpback(g,c,nk1,k2,c,nest)
-c computation of f(p).
- fp = 0.0d0
- l = k2
- do 330 it=1,m
- if(x(it).lt.t(l) .or. l.gt.nk1) go to 310
- l = l+1
- 310 l0 = l-k2
- term = 0.0d0
- do 320 j=1,k1
- l0 = l0+1
- term = term+c(l0)*q(it,j)
- 320 continue
- fp = fp+(w(it)*(term-y(it)))**2
- 330 continue
-c test whether the approximation sp(x) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximal number of iterations is reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 340
- if((f2-f3).gt.acc) go to 335
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p=p1*con9 + p2*con1
- go to 360
- 335 if(f2.lt.0.0d0) ich3=1
- 340 if(ich1.ne.0) go to 350
- if((f1-f2).gt.acc) go to 345
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 360
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 360
- 345 if(f2.gt.0.0d0) ich1=1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 350 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value for p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 360 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- 440 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcuro.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcuro.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcuro.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,94 +0,0 @@
- subroutine fpcuro(a,b,c,d,x,n)
-c subroutine fpcuro finds the real zeros of a cubic polynomial
-c p(x) = a*x**3+b*x**2+c*x+d.
-c
-c calling sequence:
-c call fpcuro(a,b,c,d,x,n)
-c
-c input parameters:
-c a,b,c,d: real values, containing the coefficients of p(x).
-c
-c output parameters:
-c x : real array,length 3, which contains the real zeros of p(x)
-c n : integer, giving the number of real zeros of p(x).
-c ..
-c ..scalar arguments..
- real*8 a,b,c,d
- integer n
-c ..array argument..
- real*8 x(3)
-c ..local scalars..
- integer i
- real*8 a1,b1,c1,df,disc,d1,e3,f,four,half,ovfl,pi3,p3,q,r,
- * step,tent,three,two,u,u1,u2,y
-c ..function references..
- real*8 abs,max,datan,atan2,cos,sign,sqrt
-c set constants
- two = 0.2d+01
- three = 0.3d+01
- four = 0.4d+01
- ovfl =0.1d+05
- half = 0.5d+0
- tent = 0.1d+0
- e3 = tent/0.3d0
- pi3 = datan(0.1d+01)/0.75d0
- a1 = abs(a)
- b1 = abs(b)
- c1 = abs(c)
- d1 = abs(d)
-c test whether p(x) is a third degree polynomial.
- if(max(b1,c1,d1).lt.a1*ovfl) go to 300
-c test whether p(x) is a second degree polynomial.
- if(max(c1,d1).lt.b1*ovfl) go to 200
-c test whether p(x) is a first degree polynomial.
- if(d1.lt.c1*ovfl) go to 100
-c p(x) is a constant function.
- n = 0
- go to 800
-c p(x) is a first degree polynomial.
- 100 n = 1
- x(1) = -d/c
- go to 500
-c p(x) is a second degree polynomial.
- 200 disc = c*c-four*b*d
- n = 0
- if(disc.lt.0.) go to 800
- n = 2
- u = sqrt(disc)
- b1 = b+b
- x(1) = (-c+u)/b1
- x(2) = (-c-u)/b1
- go to 500
-c p(x) is a third degree polynomial.
- 300 b1 = b/a*e3
- c1 = c/a
- d1 = d/a
- q = c1*e3-b1*b1
- r = b1*b1*b1+(d1-b1*c1)*half
- disc = q*q*q+r*r
- if(disc.gt.0.) go to 400
- u = sqrt(abs(q))
- if(r.lt.0.) u = -u
- p3 = atan2(sqrt(-disc),abs(r))*e3
- u2 = u+u
- n = 3
- x(1) = -u2*cos(p3)-b1
- x(2) = u2*cos(pi3-p3)-b1
- x(3) = u2*cos(pi3+p3)-b1
- go to 500
- 400 u = sqrt(disc)
- u1 = -r+u
- u2 = -r-u
- n = 1
- x(1) = sign(abs(u1)**e3,u1)+sign(abs(u2)**e3,u2)-b1
-c apply a newton iteration to improve the accuracy of the roots.
- 500 do 700 i=1,n
- y = x(i)
- f = ((a*y+b)*y+c)*y+d
- df = (three*a*y+two*b)*y+c
- step = 0.
- if(abs(f).lt.abs(df)*tent) step = f/df
- x(i) = y-step
- 700 continue
- 800 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcyt1.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcyt1.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcyt1.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,53 +0,0 @@
- subroutine fpcyt1(a,n,nn)
-c (l u)-decomposition of a cyclic tridiagonal matrix with the non-zero
-c elements stored as follows
-c
-c | a(1,2) a(1,3) a(1,1) |
-c | a(2,1) a(2,2) a(2,3) |
-c | a(3,1) a(3,2) a(3,3) |
-c | ............... |
-c | a(n-1,1) a(n-1,2) a(n-1,3) |
-c | a(n,3) a(n,1) a(n,2) |
-c
-c ..
-c ..scalar arguments..
- integer n,nn
-c ..array arguments..
- real*8 a(nn,6)
-c ..local scalars..
- real*8 aa,beta,gamma,sum,teta,v,one
- integer i,n1,n2
-c ..
-c set constant
- one = 1
- n2 = n-2
- beta = one/a(1,2)
- gamma = a(n,3)
- teta = a(1,1)*beta
- a(1,4) = beta
- a(1,5) = gamma
- a(1,6) = teta
- sum = gamma*teta
- do 10 i=2,n2
- v = a(i-1,3)*beta
- aa = a(i,1)
- beta = one/(a(i,2)-aa*v)
- gamma = -gamma*v
- teta = -teta*aa*beta
- a(i,4) = beta
- a(i,5) = gamma
- a(i,6) = teta
- sum = sum+gamma*teta
- 10 continue
- n1 = n-1
- v = a(n2,3)*beta
- aa = a(n1,1)
- beta = one/(a(n1,2)-aa*v)
- gamma = a(n,1)-gamma*v
- teta = (a(n1,3)-teta*aa)*beta
- a(n1,4) = beta
- a(n1,5) = gamma
- a(n1,6) = teta
- a(n,4) = one/(a(n,2)-(sum+gamma*teta))
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpcyt2.f
===================================================================
--- branches/Interpolate1D/fitpack/fpcyt2.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpcyt2.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,32 +0,0 @@
- subroutine fpcyt2(a,n,b,c,nn)
-c subroutine fpcyt2 solves a linear n x n system
-c a * c = b
-c where matrix a is a cyclic tridiagonal matrix, decomposed
-c using subroutine fpsyt1.
-c ..
-c ..scalar arguments..
- integer n,nn
-c ..array arguments..
- real*8 a(nn,6),b(n),c(n)
-c ..local scalars..
- real*8 cc,sum
- integer i,j,j1,n1
-c ..
- c(1) = b(1)*a(1,4)
- sum = c(1)*a(1,5)
- n1 = n-1
- do 10 i=2,n1
- c(i) = (b(i)-a(i,1)*c(i-1))*a(i,4)
- sum = sum+c(i)*a(i,5)
- 10 continue
- cc = (b(n)-sum)*a(n,4)
- c(n) = cc
- c(n1) = c(n1)-cc*a(n1,6)
- j = n1
- do 20 i=3,n
- j1 = j-1
- c(j1) = c(j1)-c(j)*a(j1,3)*a(j1,4)-cc*a(j1,6)
- j = j1
- 20 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpdeno.f
===================================================================
--- branches/Interpolate1D/fitpack/fpdeno.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpdeno.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,55 +0,0 @@
- subroutine fpdeno(maxtr,up,left,right,nbind,merk)
-c subroutine fpdeno frees the nodes of all branches of a triply linked
-c tree with length < nbind by putting to zero their up field.
-c on exit the parameter merk points to the terminal node of the
-c most left branch of length nbind or takes the value 1 if there
-c is no such branch.
-c ..
-c ..scalar arguments..
- integer maxtr,nbind,merk
-c ..array arguments..
- integer up(maxtr),left(maxtr),right(maxtr)
-c ..local scalars ..
- integer i,j,k,l,niveau,point
-c ..
- i = 1
- niveau = 0
- 10 point = i
- i = left(point)
- if(i.eq.0) go to 20
- niveau = niveau+1
- go to 10
- 20 if(niveau.eq.nbind) go to 70
- 30 i = right(point)
- j = up(point)
- up(point) = 0
- k = left(j)
- if(point.ne.k) go to 50
- if(i.ne.0) go to 40
- niveau = niveau-1
- if(niveau.eq.0) go to 80
- point = j
- go to 30
- 40 left(j) = i
- go to 10
- 50 l = right(k)
- if(point.eq.l) go to 60
- k = l
- go to 50
- 60 right(k) = i
- point = k
- 70 i = right(point)
- if(i.ne.0) go to 10
- i = up(point)
- niveau = niveau-1
- if(niveau.eq.0) go to 80
- point = i
- go to 70
- 80 k = 1
- l = left(k)
- if(up(l).eq.0) return
- 90 merk = k
- k = left(k)
- if(k.ne.0) go to 90
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpdisc.f
===================================================================
--- branches/Interpolate1D/fitpack/fpdisc.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpdisc.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,43 +0,0 @@
- subroutine fpdisc(t,n,k2,b,nest)
-c subroutine fpdisc calculates the discontinuity jumps of the kth
-c derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1)
-c ..scalar arguments..
- integer n,k2,nest
-c ..array arguments..
- real*8 t(n),b(nest,k2)
-c ..local scalars..
- real*8 an,fac,prod
- integer i,ik,j,jk,k,k1,l,lj,lk,lmk,lp,nk1,nrint
-c ..local array..
- real*8 h(12)
-c ..
- k1 = k2-1
- k = k1-1
- nk1 = n-k1
- nrint = nk1-k
- an = nrint
- fac = an/(t(nk1+1)-t(k1))
- do 40 l=k2,nk1
- lmk = l-k1
- do 10 j=1,k1
- ik = j+k1
- lj = l+j
- lk = lj-k2
- h(j) = t(l)-t(lk)
- h(ik) = t(l)-t(lj)
- 10 continue
- lp = lmk
- do 30 j=1,k2
- jk = j
- prod = h(j)
- do 20 i=1,k
- jk = jk+1
- prod = prod*h(jk)*fac
- 20 continue
- lk = lp+k1
- b(lmk,j) = (t(lk)-t(lp))/prod
- lp = lp+1
- 30 continue
- 40 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpfrno.f
===================================================================
--- branches/Interpolate1D/fitpack/fpfrno.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpfrno.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,69 +0,0 @@
- subroutine fpfrno(maxtr,up,left,right,info,point,merk,n1,
- * count,ier)
-c subroutine fpfrno collects the free nodes (up field zero) of the
-c triply linked tree the information of which is kept in the arrays
-c up,left,right and info. the maximal length of the branches of the
-c tree is given by n1. if no free nodes are found, the error flag
-c ier is set to 1.
-c ..
-c ..scalar arguments..
- integer maxtr,point,merk,n1,count,ier
-c ..array arguments..
- integer up(maxtr),left(maxtr),right(maxtr),info(maxtr)
-c ..local scalars
- integer i,j,k,l,n,niveau
-c ..
- ier = 1
- if(n1.eq.2) go to 140
- niveau = 1
- count = 2
- 10 j = 0
- i = 1
- 20 if(j.eq.niveau) go to 30
- k = 0
- l = left(i)
- if(l.eq.0) go to 110
- i = l
- j = j+1
- go to 20
- 30 if (i.lt.count) go to 110
- if (i.eq.count) go to 100
- go to 40
- 40 if(up(count).eq.0) go to 50
- count = count+1
- go to 30
- 50 up(count) = up(i)
- left(count) = left(i)
- right(count) = right(i)
- info(count) = info(i)
- if(merk.eq.i) merk = count
- if(point.eq.i) point = count
- if(k.eq.0) go to 60
- right(k) = count
- go to 70
- 60 n = up(i)
- left(n) = count
- 70 l = left(i)
- 80 if(l.eq.0) go to 90
- up(l) = count
- l = right(l)
- go to 80
- 90 up(i) = 0
- i = count
- 100 count = count+1
- 110 l = right(i)
- k = i
- if(l.eq.0) go to 120
- i = l
- go to 20
- 120 l = up(i)
- j = j-1
- if(j.eq.0) go to 130
- i = l
- go to 110
- 130 niveau = niveau+1
- if(niveau.le.n1) go to 10
- if(count.gt.maxtr) go to 140
- ier = 0
- 140 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpgivs.f
===================================================================
--- branches/Interpolate1D/fitpack/fpgivs.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpgivs.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,20 +0,0 @@
- subroutine fpgivs(piv,ww,cos,sin)
-c subroutine fpgivs calculates the parameters of a givens
-c transformation .
-c ..
-c ..scalar arguments..
- real*8 piv,ww,cos,sin
-c ..local scalars..
- real*8 dd,one,store
-c ..function references..
- real*8 abs,sqrt
-c ..
- one = 0.1e+01
- store = abs(piv)
- if(store.ge.ww) dd = store*sqrt(one+(ww/piv)**2)
- if(store.lt.ww) dd = ww*sqrt(one+(piv/ww)**2)
- cos = ww/dd
- sin = piv/dd
- ww = dd
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpgrdi.f
===================================================================
--- branches/Interpolate1D/fitpack/fpgrdi.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpgrdi.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,600 +0,0 @@
- subroutine fpgrdi(ifsu,ifsv,ifbu,ifbv,iback,u,mu,v,mv,z,mz,dz,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,spu,spv,
- * right,q,au,av1,av2,bu,bv,aa,bb,cc,cosi,nru,nrv)
-c ..
-c ..scalar arguments..
- real*8 p,sq,fp
- integer ifsu,ifsv,ifbu,ifbv,iback,mu,mv,mz,iop0,iop1,nu,nv,nc,
- * mm,mvnu
-c ..array arguments..
- real*8 u(mu),v(mv),z(mz),dz(3),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv)
- *,
- * spu(mu,4),spv(mv,4),right(mm),q(mvnu),au(nu,5),av1(nv,6),
- * av2(nv,4),aa(2,mv),bb(2,nv),cc(nv),cosi(2,nv),bu(nu,5),bv(nv,5)
- integer nru(mu),nrv(mv)
-c ..local scalars..
- real*8 arg,co,dz1,dz2,dz3,fac,fac0,pinv,piv,si,term,one,three,half
- *
- integer i,ic,ii,ij,ik,iq,irot,it,iz,i0,i1,i2,i3,j,jj,jk,jper,
- * j0,j1,k,k1,k2,l,l0,l1,l2,mvv,ncof,nrold,nroldu,nroldv,number,
- * numu,numu1,numv,numv1,nuu,nu4,nu7,nu8,nu9,nv11,nv4,nv7,nv8,n1
-c ..local arrays..
- real*8 h(5),h1(5),h2(4)
-c ..function references..
- integer min0
- real*8 cos,sin
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpcyt1,fpcyt2,fpdisc,fpbacp,fprota
-c ..
-c let
-c | (spu) | | (spv) |
-c (au) = | ---------- | (av) = | ---------- |
-c | (1/p) (bu) | | (1/p) (bv) |
-c
-c | z ' 0 |
-c q = | ------ |
-c | 0 ' 0 |
-c
-c with c : the (nu-4) x (nv-4) matrix which contains the b-spline
-c coefficients.
-c z : the mu x mv matrix which contains the function values.
-c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices
-c according to the least-squares problems in the u-,resp.
-c v-direction.
-c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices
-c containing the discontinuity jumps of the derivatives
-c of the b-splines in the u-,resp.v-variable at the knots
-c the b-spline coefficients of the smoothing spline are then calculated
-c as the least-squares solution of the following over-determined linear
-c system of equations
-c
-c (1) (av) c (au)' = q
-c
-c subject to the constraints
-c
-c (2) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4
-c
-c (3) if iop0 = 0 c(1,j) = dz(1)
-c iop0 = 1 c(1,j) = dz(1)
-c c(2,j) = dz(1)+(dz(2)*cosi(1,j)+dz(3)*cosi(2,j))*
-c tu(5)/3. = cc(j) , j=1,2,...nv-4
-c
-c (4) if iop1 = 1 c(nu-4,j) = 0, j=1,2,...,nv-4.
-c
-c set constants
- one = 1
- three = 3
- half = 0.5
-c initialization
- nu4 = nu-4
- nu7 = nu-7
- nu8 = nu-8
- nu9 = nu-9
- nv4 = nv-4
- nv7 = nv-7
- nv8 = nv-8
- nv11 = nv-11
- nuu = nu4-iop0-iop1-1
- if(p.gt.0.) pinv = one/p
-c it depends on the value of the flags ifsu,ifsv,ifbu,ifbv and iop0 and
-c on the value of p whether the matrices (spu), (spv), (bu), (bv) and
-c (cosi) still must be determined.
- if(ifsu.ne.0) go to 30
-c calculate the non-zero elements of the matrix (spu) which is the ob-
-c servation matrix according to the least-squares spline approximation
-c problem in the u-direction.
- l = 4
- l1 = 5
- number = 0
- do 25 it=1,mu
- arg = u(it)
- 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 15
- l = l1
- l1 = l+1
- number = number+1
- go to 10
- 15 call fpbspl(tu,nu,3,arg,l,h)
- do 20 i=1,4
- spu(it,i) = h(i)
- 20 continue
- nru(it) = number
- 25 continue
- ifsu = 1
-c calculate the non-zero elements of the matrix (spv) which is the ob-
-c servation matrix according to the least-squares spline approximation
-c problem in the v-direction.
- 30 if(ifsv.ne.0) go to 85
- l = 4
- l1 = 5
- number = 0
- do 50 it=1,mv
- arg = v(it)
- 35 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 40
- l = l1
- l1 = l+1
- number = number+1
- go to 35
- 40 call fpbspl(tv,nv,3,arg,l,h)
- do 45 i=1,4
- spv(it,i) = h(i)
- 45 continue
- nrv(it) = number
- 50 continue
- ifsv = 1
- if(iop0.eq.0) go to 85
-c calculate the coefficients of the interpolating splines for cos(v)
-c and sin(v).
- do 55 i=1,nv4
- cosi(1,i) = 0.
- cosi(2,i) = 0.
- 55 continue
- if(nv7.lt.4) go to 85
- do 65 i=1,nv7
- l = i+3
- arg = tv(l)
- call fpbspl(tv,nv,3,arg,l,h)
- do 60 j=1,3
- av1(i,j) = h(j)
- 60 continue
- cosi(1,i) = cos(arg)
- cosi(2,i) = sin(arg)
- 65 continue
- call fpcyt1(av1,nv7,nv)
- do 80 j=1,2
- do 70 i=1,nv7
- right(i) = cosi(j,i)
- 70 continue
- call fpcyt2(av1,nv7,right,right,nv)
- do 75 i=1,nv7
- cosi(j,i+1) = right(i)
- 75 continue
- cosi(j,1) = cosi(j,nv7+1)
- cosi(j,nv7+2) = cosi(j,2)
- cosi(j,nv4) = cosi(j,3)
- 80 continue
- 85 if(p.le.0.) go to 150
-c calculate the non-zero elements of the matrix (bu).
- if(ifbu.ne.0 .or. nu8.eq.0) go to 90
- call fpdisc(tu,nu,5,bu,nu)
- ifbu = 1
-c calculate the non-zero elements of the matrix (bv).
- 90 if(ifbv.ne.0 .or. nv8.eq.0) go to 150
- call fpdisc(tv,nv,5,bv,nv)
- ifbv = 1
-c substituting (2),(3) and (4) into (1), we obtain the overdetermined
-c system
-c (5) (avv) (cr) (auu)' = (qq)
-c from which the nuu*nv7 remaining coefficients
-c c(i,j) , i=2+iop0,3+iop0,...,nu-4-iop1 ; j=1,2,...,nv-7 ,
-c the elements of (cr), are then determined in the least-squares sense.
-c simultaneously, we compute the resulting sum of squared residuals sq.
- 150 dz1 = dz(1)
- do 155 i=1,mv
- aa(1,i) = dz1
- 155 continue
- if(nv8.eq.0 .or. p.le.0.) go to 165
- do 160 i=1,nv8
- bb(1,i) = 0.
- 160 continue
- 165 mvv = mv
- if(iop0.eq.0) go to 220
- fac = tu(5)/three
- dz2 = dz(2)*fac
- dz3 = dz(3)*fac
- do 170 i=1,nv4
- cc(i) = dz1+dz2*cosi(1,i)+dz3*cosi(2,i)
- 170 continue
- do 190 i=1,mv
- number = nrv(i)
- fac = 0.
- do 180 j=1,4
- number = number+1
- fac = fac+cc(number)*spv(i,j)
- 180 continue
- aa(2,i) = fac
- 190 continue
- if(nv8.eq.0 .or. p.le.0.) go to 220
- do 210 i=1,nv8
- number = i
- fac = 0.
- do 200 j=1,5
- fac = fac+cc(number)*bv(i,j)
- number = number+1
- 200 continue
- bb(2,i) = fac*pinv
- 210 continue
- mvv = mvv+nv8
-c we first determine the matrices (auu) and (qq). then we reduce the
-c matrix (auu) to upper triangular form (ru) using givens rotations.
-c we apply the same transformations to the rows of matrix qq to obtain
-c the (mv+nv8) x nuu matrix g.
-c we store matrix (ru) into au and g into q.
- 220 l = mvv*nuu
-c initialization.
- sq = 0.
- do 230 i=1,l
- q(i) = 0.
- 230 continue
- do 240 i=1,nuu
- do 240 j=1,5
- au(i,j) = 0.
- 240 continue
- l = 0
- nrold = 0
- n1 = nrold+1
- do 420 it=1,mu
- number = nru(it)
-c find the appropriate column of q.
- 250 do 260 j=1,mvv
- right(j) = 0.
- 260 continue
- if(nrold.eq.number) go to 280
- if(p.le.0.) go to 410
-c fetch a new row of matrix (bu).
- do 270 j=1,5
- h(j) = bu(n1,j)*pinv
- 270 continue
- i0 = 1
- i1 = 5
- go to 310
-c fetch a new row of matrix (spu).
- 280 do 290 j=1,4
- h(j) = spu(it,j)
- 290 continue
-c find the appropriate column of q.
- do 300 j=1,mv
- l = l+1
- right(j) = z(l)
- 300 continue
- i0 = 1
- i1 = 4
- 310 if(nu7-number .eq. iop1) i1 = i1-1
- j0 = n1
-c take into account that we eliminate the constraints (3)
- 320 if(j0-1.gt.iop0) go to 360
- fac0 = h(i0)
- do 330 j=1,mv
- right(j) = right(j)-fac0*aa(j0,j)
- 330 continue
- if(mv.eq.mvv) go to 350
- j = mv
- do 340 jj=1,nv8
- j = j+1
- right(j) = right(j)-fac0*bb(j0,jj)
- 340 continue
- 350 j0 = j0+1
- i0 = i0+1
- go to 320
- 360 irot = nrold-iop0-1
- if(irot.lt.0) irot = 0
-c rotate the new row of matrix (auu) into triangle.
- do 390 i=i0,i1
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 390
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,au(irot,1),co,si)
-c apply that transformation to the rows of matrix (qq).
- iq = (irot-1)*mvv
- do 370 j=1,mvv
- iq = iq+1
- call fprota(co,si,right(j),q(iq))
- 370 continue
-c apply that transformation to the columns of (auu).
- if(i.eq.i1) go to 390
- i2 = 1
- i3 = i+1
- do 380 j=i3,i1
- i2 = i2+1
- call fprota(co,si,h(j),au(irot,i2))
- 380 continue
- 390 continue
-c we update the sum of squared residuals
- do 395 j=1,mvv
- sq = sq+right(j)**2
- 395 continue
- 400 if(nrold.eq.number) go to 420
- 410 nrold = n1
- n1 = n1+1
- go to 250
- 420 continue
-c we determine the matrix (avv) and then we reduce her to
-c upper triangular form (rv) using givens rotations.
-c we apply the same transformations to the columns of matrix
-c g to obtain the (nv-7) x (nu-5-iop0-iop1) matrix h.
-c we store matrix (rv) into av1 and av2, h into c.
-c the nv7 x nv7 upper triangular matrix (rv) has the form
-c | av1 ' |
-c (rv) = | ' av2 |
-c | 0 ' |
-c with (av2) a nv7 x 4 matrix and (av1) a nv11 x nv11 upper
-c triangular matrix of bandwidth 5.
- ncof = nuu*nv7
-c initialization.
- do 430 i=1,ncof
- c(i) = 0.
- 430 continue
- do 440 i=1,nv4
- av1(i,5) = 0.
- do 440 j=1,4
- av1(i,j) = 0.
- av2(i,j) = 0.
- 440 continue
- jper = 0
- nrold = 0
- do 770 it=1,mv
- number = nrv(it)
- 450 if(nrold.eq.number) go to 480
- if(p.le.0.) go to 760
-c fetch a new row of matrix (bv).
- n1 = nrold+1
- do 460 j=1,5
- h(j) = bv(n1,j)*pinv
- 460 continue
-c find the appropiate row of g.
- do 465 j=1,nuu
- right(j) = 0.
- 465 continue
- if(mv.eq.mvv) go to 510
- l = mv+n1
- do 470 j=1,nuu
- right(j) = q(l)
- l = l+mvv
- 470 continue
- go to 510
-c fetch a new row of matrix (spv)
- 480 h(5) = 0.
- do 490 j=1,4
- h(j) = spv(it,j)
- 490 continue
-c find the appropiate row of g.
- l = it
- do 500 j=1,nuu
- right(j) = q(l)
- l = l+mvv
- 500 continue
-c test whether there are non-zero values in the new row of (avv)
-c corresponding to the b-splines n(j,v),j=nv7+1,...,nv4.
- 510 if(nrold.lt.nv11) go to 710
- if(jper.ne.0) go to 550
-c initialize the matrix (av2).
- jk = nv11+1
- do 540 i=1,4
- ik = jk
- do 520 j=1,5
- if(ik.le.0) go to 530
- av2(ik,i) = av1(ik,j)
- ik = ik-1
- 520 continue
- 530 jk = jk+1
- 540 continue
- jper = 1
-c if one of the non-zero elements of the new row corresponds to one of
-c the b-splines n(j;v),j=nv7+1,...,nv4, we take account of condition
-c (2) for setting up this row of (avv). the row is stored in h1( the
-c part with respect to av1) and h2 (the part with respect to av2).
- 550 do 560 i=1,4
- h1(i) = 0.
- h2(i) = 0.
- 560 continue
- h1(5) = 0.
- j = nrold-nv11
- do 600 i=1,5
- j = j+1
- l0 = j
- 570 l1 = l0-4
- if(l1.le.0) go to 590
- if(l1.le.nv11) go to 580
- l0 = l1-nv11
- go to 570
- 580 h1(l1) = h(i)
- go to 600
- 590 h2(l0) = h2(l0) + h(i)
- 600 continue
-c rotate the new row of (avv) into triangle.
- if(nv11.le.0) go to 670
-c rotations with the rows 1,2,...,nv11 of (avv).
- do 660 j=1,nv11
- piv = h1(1)
- i2 = min0(nv11-j,4)
- if(piv.eq.0.) go to 640
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,av1(j,1),co,si)
-c apply that transformation to the columns of matrix g.
- ic = j
- do 610 i=1,nuu
- call fprota(co,si,right(i),c(ic))
- ic = ic+nv7
- 610 continue
-c apply that transformation to the rows of (avv) with respect to av2.
- do 620 i=1,4
- call fprota(co,si,h2(i),av2(j,i))
- 620 continue
-c apply that transformation to the rows of (avv) with respect to av1.
- if(i2.eq.0) go to 670
- do 630 i=1,i2
- i1 = i+1
- call fprota(co,si,h1(i1),av1(j,i1))
- 630 continue
- 640 do 650 i=1,i2
- h1(i) = h1(i+1)
- 650 continue
- h1(i2+1) = 0.
- 660 continue
-c rotations with the rows nv11+1,...,nv7 of avv.
- 670 do 700 j=1,4
- ij = nv11+j
- if(ij.le.0) go to 700
- piv = h2(j)
- if(piv.eq.0.) go to 700
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,av2(ij,j),co,si)
-c apply that transformation to the columns of matrix g.
- ic = ij
- do 680 i=1,nuu
- call fprota(co,si,right(i),c(ic))
- ic = ic+nv7
- 680 continue
- if(j.eq.4) go to 700
-c apply that transformation to the rows of (avv) with respect to av2.
- j1 = j+1
- do 690 i=j1,4
- call fprota(co,si,h2(i),av2(ij,i))
- 690 continue
- 700 continue
-c we update the sum of squared residuals
- do 705 i=1,nuu
- sq = sq+right(i)**2
- 705 continue
- go to 750
-c rotation into triangle of the new row of (avv), in case the elements
-c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4 are all zero.
- 710 irot =nrold
- do 740 i=1,5
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 740
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,av1(irot,1),co,si)
-c apply that transformation to the columns of matrix g.
- ic = irot
- do 720 j=1,nuu
- call fprota(co,si,right(j),c(ic))
- ic = ic+nv7
- 720 continue
-c apply that transformation to the rows of (avv).
- if(i.eq.5) go to 740
- i2 = 1
- i3 = i+1
- do 730 j=i3,5
- i2 = i2+1
- call fprota(co,si,h(j),av1(irot,i2))
- 730 continue
- 740 continue
-c we update the sum of squared residuals
- do 745 i=1,nuu
- sq = sq+right(i)**2
- 745 continue
- 750 if(nrold.eq.number) go to 770
- 760 nrold = nrold+1
- go to 450
- 770 continue
-c test whether the b-spline coefficients must be determined.
- if(iback.ne.0) return
-c backward substitution to obtain the b-spline coefficients as the
-c solution of the linear system (rv) (cr) (ru)' = h.
-c first step: solve the system (rv) (c1) = h.
- k = 1
- do 780 i=1,nuu
- call fpbacp(av1,av2,c(k),nv7,4,c(k),5,nv)
- k = k+nv7
- 780 continue
-c second step: solve the system (cr) (ru)' = (c1).
- k = 0
- do 800 j=1,nv7
- k = k+1
- l = k
- do 790 i=1,nuu
- right(i) = c(l)
- l = l+nv7
- 790 continue
- call fpback(au,right,nuu,5,right,nu)
- l = k
- do 795 i=1,nuu
- c(l) = right(i)
- l = l+nv7
- 795 continue
- 800 continue
-c calculate from the conditions (2)-(3)-(4), the remaining b-spline
-c coefficients.
- ncof = nu4*nv4
- i = nv4
- j = 0
- do 805 l=1,nv4
- q(l) = dz1
- 805 continue
- if(iop0.eq.0) go to 815
- do 810 l=1,nv4
- i = i+1
- q(i) = cc(l)
- 810 continue
- 815 if(nuu.eq.0) go to 850
- do 840 l=1,nuu
- ii = i
- do 820 k=1,nv7
- i = i+1
- j = j+1
- q(i) = c(j)
- 820 continue
- do 830 k=1,3
- ii = ii+1
- i = i+1
- q(i) = q(ii)
- 830 continue
- 840 continue
- 850 if(iop1.eq.0) go to 870
- do 860 l=1,nv4
- i = i+1
- q(i) = 0.
- 860 continue
- 870 do 880 i=1,ncof
- c(i) = q(i)
- 880 continue
-c calculate the quantities
-c res(i,j) = (z(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv
-c fp = sumi=1,mu(sumj=1,mv(res(i,j)))
-c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7
-c tu(r+3) <= u(i) <= tu(r+4)
-c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7
-c tv(r+3) <= v(j) <= tv(r+4)
- fp = 0.
- do 890 i=1,nu
- fpu(i) = 0.
- 890 continue
- do 900 i=1,nv
- fpv(i) = 0.
- 900 continue
- iz = 0
- nroldu = 0
-c main loop for the different grid points.
- do 950 i1=1,mu
- numu = nru(i1)
- numu1 = numu+1
- nroldv = 0
- do 940 i2=1,mv
- numv = nrv(i2)
- numv1 = numv+1
- iz = iz+1
-c evaluate s(u,v) at the current grid point by making the sum of the
-c cross products of the non-zero b-splines at (u,v), multiplied with
-c the appropiate b-spline coefficients.
- term = 0.
- k1 = numu*nv4+numv
- do 920 l1=1,4
- k2 = k1
- fac = spu(i1,l1)
- do 910 l2=1,4
- k2 = k2+1
- term = term+fac*spv(i2,l2)*c(k2)
- 910 continue
- k1 = k1+nv4
- 920 continue
-c calculate the squared residual at the current grid point.
- term = (z(iz)-term)**2
-c adjust the different parameters.
- fp = fp+term
- fpu(numu1) = fpu(numu1)+term
- fpv(numv1) = fpv(numv1)+term
- fac = term*half
- if(numv.eq.nroldv) go to 930
- fpv(numv1) = fpv(numv1)-fac
- fpv(numv) = fpv(numv)+fac
- 930 nroldv = numv
- if(numu.eq.nroldu) go to 940
- fpu(numu1) = fpu(numu1)-fac
- fpu(numu) = fpu(numu)+fac
- 940 continue
- nroldu = numu
- 950 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpgrpa.f
===================================================================
--- branches/Interpolate1D/fitpack/fpgrpa.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpgrpa.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,313 +0,0 @@
- subroutine fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,
- * tu,nu,tv,nv,p,c,nc,fp,fpu,fpv,mm,mvnu,spu,spv,right,q,au,au1,
- * av,av1,bu,bv,nru,nrv)
-c ..
-c ..scalar arguments..
- real*8 p,fp
- integer ifsu,ifsv,ifbu,ifbv,idim,mu,mv,mz,nu,nv,nc,mm,mvnu
-c ..array arguments..
- real*8 u(mu),v(mv),z(mz*idim),tu(nu),tv(nv),c(nc*idim),fpu(nu),
- * fpv(nv),spu(mu,4),spv(mv,4),right(mm*idim),q(mvnu),au(nu,5),
- * au1(nu,4),av(nv,5),av1(nv,4),bu(nu,5),bv(nv,5)
- integer ipar(2),nru(mu),nrv(mv)
-c ..local scalars..
- real*8 arg,fac,term,one,half,value
- integer i,id,ii,it,iz,i1,i2,j,jz,k,k1,k2,l,l1,l2,mvv,k0,muu,
- * ncof,nroldu,nroldv,number,nmd,numu,numu1,numv,numv1,nuu,nvv,
- * nu4,nu7,nu8,nv4,nv7,nv8
-c ..local arrays..
- real*8 h(5)
-c ..subroutine references..
-c fpback,fpbspl,fpdisc,fpbacp,fptrnp,fptrpe
-c ..
-c let
-c | (spu) | | (spv) |
-c (au) = | ---------- | (av) = | ---------- |
-c | (1/p) (bu) | | (1/p) (bv) |
-c
-c | z ' 0 |
-c q = | ------ |
-c | 0 ' 0 |
-c
-c with c : the (nu-4) x (nv-4) matrix which contains the b-spline
-c coefficients.
-c z : the mu x mv matrix which contains the function values.
-c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices
-c according to the least-squares problems in the u-,resp.
-c v-direction.
-c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices
-c containing the discontinuity jumps of the derivatives
-c of the b-splines in the u-,resp.v-variable at the knots
-c the b-spline coefficients of the smoothing spline are then calculated
-c as the least-squares solution of the following over-determined linear
-c system of equations
-c
-c (1) (av) c (au)' = q
-c
-c subject to the constraints
-c
-c (2) c(nu-3+i,j) = c(i,j), i=1,2,3 ; j=1,2,...,nv-4
-c if(ipar(1).ne.0)
-c
-c (3) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4
-c if(ipar(2).ne.0)
-c
-c set constants
- one = 1
- half = 0.5
-c initialization
- nu4 = nu-4
- nu7 = nu-7
- nu8 = nu-8
- nv4 = nv-4
- nv7 = nv-7
- nv8 = nv-8
- muu = mu
- if(ipar(1).ne.0) muu = mu-1
- mvv = mv
- if(ipar(2).ne.0) mvv = mv-1
-c it depends on the value of the flags ifsu,ifsv,ifbu and ibvand
-c on the value of p whether the matrices (spu), (spv), (bu) and (bv)
-c still must be determined.
- if(ifsu.ne.0) go to 50
-c calculate the non-zero elements of the matrix (spu) which is the ob-
-c servation matrix according to the least-squares spline approximation
-c problem in the u-direction.
- l = 4
- l1 = 5
- number = 0
- do 40 it=1,muu
- arg = u(it)
- 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20
- l = l1
- l1 = l+1
- number = number+1
- go to 10
- 20 call fpbspl(tu,nu,3,arg,l,h)
- do 30 i=1,4
- spu(it,i) = h(i)
- 30 continue
- nru(it) = number
- 40 continue
- ifsu = 1
-c calculate the non-zero elements of the matrix (spv) which is the ob-
-c servation matrix according to the least-squares spline approximation
-c problem in the v-direction.
- 50 if(ifsv.ne.0) go to 100
- l = 4
- l1 = 5
- number = 0
- do 90 it=1,mvv
- arg = v(it)
- 60 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 70
- l = l1
- l1 = l+1
- number = number+1
- go to 60
- 70 call fpbspl(tv,nv,3,arg,l,h)
- do 80 i=1,4
- spv(it,i) = h(i)
- 80 continue
- nrv(it) = number
- 90 continue
- ifsv = 1
- 100 if(p.le.0.) go to 150
-c calculate the non-zero elements of the matrix (bu).
- if(ifbu.ne.0 .or. nu8.eq.0) go to 110
- call fpdisc(tu,nu,5,bu,nu)
- ifbu = 1
-c calculate the non-zero elements of the matrix (bv).
- 110 if(ifbv.ne.0 .or. nv8.eq.0) go to 150
- call fpdisc(tv,nv,5,bv,nv)
- ifbv = 1
-c substituting (2) and (3) into (1), we obtain the overdetermined
-c system
-c (4) (avv) (cr) (auu)' = (qq)
-c from which the nuu*nvv remaining coefficients
-c c(i,j) , i=1,...,nu-4-3*ipar(1) ; j=1,...,nv-4-3*ipar(2) ,
-c the elements of (cr), are then determined in the least-squares sense.
-c we first determine the matrices (auu) and (qq). then we reduce the
-c matrix (auu) to upper triangular form (ru) using givens rotations.
-c we apply the same transformations to the rows of matrix qq to obtain
-c the (mv) x nuu matrix g.
-c we store matrix (ru) into au (and au1 if ipar(1)=1) and g into q.
- 150 if(ipar(1).ne.0) go to 160
- nuu = nu4
- call fptrnp(mu,mv,idim,nu,nru,spu,p,bu,z,au,q,right)
- go to 180
- 160 nuu = nu7
- call fptrpe(mu,mv,idim,nu,nru,spu,p,bu,z,au,au1,q,right)
-c we determine the matrix (avv) and then we reduce this matrix to
-c upper triangular form (rv) using givens rotations.
-c we apply the same transformations to the columns of matrix
-c g to obtain the (nvv) x (nuu) matrix h.
-c we store matrix (rv) into av (and av1 if ipar(2)=1) and h into c.
- 180 if(ipar(2).ne.0) go to 190
- nvv = nv4
- call fptrnp(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,c,right)
- go to 200
- 190 nvv = nv7
- call fptrpe(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,av1,c,right)
-c backward substitution to obtain the b-spline coefficients as the
-c solution of the linear system (rv) (cr) (ru)' = h.
-c first step: solve the system (rv) (c1) = h.
- 200 ncof = nuu*nvv
- k = 1
- if(ipar(2).ne.0) go to 240
- do 220 ii=1,idim
- do 220 i=1,nuu
- call fpback(av,c(k),nvv,5,c(k),nv)
- k = k+nvv
- 220 continue
- go to 300
- 240 do 260 ii=1,idim
- do 260 i=1,nuu
- call fpbacp(av,av1,c(k),nvv,4,c(k),5,nv)
- k = k+nvv
- 260 continue
-c second step: solve the system (cr) (ru)' = (c1).
- 300 if(ipar(1).ne.0) go to 400
- do 360 ii=1,idim
- k = (ii-1)*ncof
- do 360 j=1,nvv
- k = k+1
- l = k
- do 320 i=1,nuu
- right(i) = c(l)
- l = l+nvv
- 320 continue
- call fpback(au,right,nuu,5,right,nu)
- l = k
- do 340 i=1,nuu
- c(l) = right(i)
- l = l+nvv
- 340 continue
- 360 continue
- go to 500
- 400 do 460 ii=1,idim
- k = (ii-1)*ncof
- do 460 j=1,nvv
- k = k+1
- l = k
- do 420 i=1,nuu
- right(i) = c(l)
- l = l+nvv
- 420 continue
- call fpbacp(au,au1,right,nuu,4,right,5,nu)
- l = k
- do 440 i=1,nuu
- c(l) = right(i)
- l = l+nvv
- 440 continue
- 460 continue
-c calculate from the conditions (2)-(3), the remaining b-spline
-c coefficients.
- 500 if(ipar(2).eq.0) go to 600
- i = 0
- j = 0
- do 560 id=1,idim
- do 560 l=1,nuu
- ii = i
- do 520 k=1,nvv
- i = i+1
- j = j+1
- q(i) = c(j)
- 520 continue
- do 540 k=1,3
- ii = ii+1
- i = i+1
- q(i) = q(ii)
- 540 continue
- 560 continue
- ncof = nv4*nuu
- nmd = ncof*idim
- do 580 i=1,nmd
- c(i) = q(i)
- 580 continue
- 600 if(ipar(1).eq.0) go to 700
- i = 0
- j = 0
- n33 = 3*nv4
- do 660 id=1,idim
- ii = i
- do 620 k=1,ncof
- i = i+1
- j = j+1
- q(i) = c(j)
- 620 continue
- do 640 k=1,n33
- ii = ii+1
- i = i+1
- q(i) = q(ii)
- 640 continue
- 660 continue
- ncof = nv4*nu4
- nmd = ncof*idim
- do 680 i=1,nmd
- c(i) = q(i)
- 680 continue
-c calculate the quantities
-c res(i,j) = (z(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv
-c fp = sumi=1,mu(sumj=1,mv(res(i,j)))
-c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7
-c tu(r+3) <= u(i) <= tu(r+4)
-c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7
-c tv(r+3) <= v(j) <= tv(r+4)
- 700 fp = 0.
- do 720 i=1,nu
- fpu(i) = 0.
- 720 continue
- do 740 i=1,nv
- fpv(i) = 0.
- 740 continue
- nroldu = 0
-c main loop for the different grid points.
- do 860 i1=1,muu
- numu = nru(i1)
- numu1 = numu+1
- nroldv = 0
- iz = (i1-1)*mv
- do 840 i2=1,mvv
- numv = nrv(i2)
- numv1 = numv+1
- iz = iz+1
-c evaluate s(u,v) at the current grid point by making the sum of the
-c cross products of the non-zero b-splines at (u,v), multiplied with
-c the appropiate b-spline coefficients.
- term = 0.
- k0 = numu*nv4+numv
- jz = iz
- do 800 id=1,idim
- k1 = k0
- value = 0.
- do 780 l1=1,4
- k2 = k1
- fac = spu(i1,l1)
- do 760 l2=1,4
- k2 = k2+1
- value = value+fac*spv(i2,l2)*c(k2)
- 760 continue
- k1 = k1+nv4
- 780 continue
-c calculate the squared residual at the current grid point.
- term = term+(z(jz)-value)**2
- jz = jz+mz
- k0 = k0+ncof
- 800 continue
-c adjust the different parameters.
- fp = fp+term
- fpu(numu1) = fpu(numu1)+term
- fpv(numv1) = fpv(numv1)+term
- fac = term*half
- if(numv.eq.nroldv) go to 820
- fpv(numv1) = fpv(numv1)-fac
- fpv(numv) = fpv(numv)+fac
- 820 nroldv = numv
- if(numu.eq.nroldu) go to 840
- fpu(numu1) = fpu(numu1)-fac
- fpu(numu) = fpu(numu)+fac
- 840 continue
- nroldu = numu
- 860 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpgrre.f
===================================================================
--- branches/Interpolate1D/fitpack/fpgrre.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpgrre.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,328 +0,0 @@
- subroutine fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,
- * ty,ny,p,c,nc,fp,fpx,fpy,mm,mynx,kx1,kx2,ky1,ky2,spx,spy,right,q,
- * ax,ay,bx,by,nrx,nry)
-c ..
-c ..scalar arguments..
- real*8 p,fp
- integer ifsx,ifsy,ifbx,ifby,mx,my,mz,kx,ky,nx,ny,nc,mm,mynx,
- * kx1,kx2,ky1,ky2
-c ..array arguments..
- real*8 x(mx),y(my),z(mz),tx(nx),ty(ny),c(nc),spx(mx,kx1),spy(my,ky
- *1)
- * ,right(mm),q(mynx),ax(nx,kx2),bx(nx,kx2),ay(ny,ky2),by(ny,ky2),
- * fpx(nx),fpy(ny)
- integer nrx(mx),nry(my)
-c ..local scalars..
- real*8 arg,cos,fac,pinv,piv,sin,term,one,half
- integer i,ibandx,ibandy,ic,iq,irot,it,iz,i1,i2,i3,j,k,k1,k2,l,
- * l1,l2,ncof,nk1x,nk1y,nrold,nroldx,nroldy,number,numx,numx1,
- * numy,numy1,n1
-c ..local arrays..
- real*8 h(7)
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpdisc,fprota
-c ..
-c the b-spline coefficients of the smoothing spline are calculated as
-c the least-squares solution of the over-determined linear system of
-c equations (ay) c (ax)' = q where
-c
-c | (spx) | | (spy) |
-c (ax) = | ---------- | (ay) = | ---------- |
-c | (1/p) (bx) | | (1/p) (by) |
-c
-c | z ' 0 |
-c q = | ------ |
-c | 0 ' 0 |
-c
-c with c : the (ny-ky-1) x (nx-kx-1) matrix which contains the
-c b-spline coefficients.
-c z : the my x mx matrix which contains the function values.
-c spx,spy: the mx x (nx-kx-1) and my x (ny-ky-1) observation
-c matrices according to the least-squares problems in
-c the x- and y-direction.
-c bx,by : the (nx-2*kx-1) x (nx-kx-1) and (ny-2*ky-1) x (ny-ky-1)
-c matrices which contain the discontinuity jumps of the
-c derivatives of the b-splines in the x- and y-direction.
- one = 1
- half = 0.5
- nk1x = nx-kx1
- nk1y = ny-ky1
- if(p.gt.0.) pinv = one/p
-c it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on
-c the value of p whether the matrices (spx),(spy),(bx) and (by) still
-c must be determined.
- if(ifsx.ne.0) go to 50
-c calculate the non-zero elements of the matrix (spx) which is the
-c observation matrix according to the least-squares spline approximat-
-c ion problem in the x-direction.
- l = kx1
- l1 = kx2
- number = 0
- do 40 it=1,mx
- arg = x(it)
- 10 if(arg.lt.tx(l1) .or. l.eq.nk1x) go to 20
- l = l1
- l1 = l+1
- number = number+1
- go to 10
- 20 call fpbspl(tx,nx,kx,arg,l,h)
- do 30 i=1,kx1
- spx(it,i) = h(i)
- 30 continue
- nrx(it) = number
- 40 continue
- ifsx = 1
- 50 if(ifsy.ne.0) go to 100
-c calculate the non-zero elements of the matrix (spy) which is the
-c observation matrix according to the least-squares spline approximat-
-c ion problem in the y-direction.
- l = ky1
- l1 = ky2
- number = 0
- do 90 it=1,my
- arg = y(it)
- 60 if(arg.lt.ty(l1) .or. l.eq.nk1y) go to 70
- l = l1
- l1 = l+1
- number = number+1
- go to 60
- 70 call fpbspl(ty,ny,ky,arg,l,h)
- do 80 i=1,ky1
- spy(it,i) = h(i)
- 80 continue
- nry(it) = number
- 90 continue
- ifsy = 1
- 100 if(p.le.0.) go to 120
-c calculate the non-zero elements of the matrix (bx).
- if(ifbx.ne.0 .or. nx.eq.2*kx1) go to 110
- call fpdisc(tx,nx,kx2,bx,nx)
- ifbx = 1
-c calculate the non-zero elements of the matrix (by).
- 110 if(ifby.ne.0 .or. ny.eq.2*ky1) go to 120
- call fpdisc(ty,ny,ky2,by,ny)
- ifby = 1
-c reduce the matrix (ax) to upper triangular form (rx) using givens
-c rotations. apply the same transformations to the rows of matrix q
-c to obtain the my x (nx-kx-1) matrix g.
-c store matrix (rx) into (ax) and g into q.
- 120 l = my*nk1x
-c initialization.
- do 130 i=1,l
- q(i) = 0.
- 130 continue
- do 140 i=1,nk1x
- do 140 j=1,kx2
- ax(i,j) = 0.
- 140 continue
- l = 0
- nrold = 0
-c ibandx denotes the bandwidth of the matrices (ax) and (rx).
- ibandx = kx1
- do 270 it=1,mx
- number = nrx(it)
- 150 if(nrold.eq.number) go to 180
- if(p.le.0.) go to 260
- ibandx = kx2
-c fetch a new row of matrix (bx).
- n1 = nrold+1
- do 160 j=1,kx2
- h(j) = bx(n1,j)*pinv
- 160 continue
-c find the appropriate column of q.
- do 170 j=1,my
- right(j) = 0.
- 170 continue
- irot = nrold
- go to 210
-c fetch a new row of matrix (spx).
- 180 h(ibandx) = 0.
- do 190 j=1,kx1
- h(j) = spx(it,j)
- 190 continue
-c find the appropriate column of q.
- do 200 j=1,my
- l = l+1
- right(j) = z(l)
- 200 continue
- irot = number
-c rotate the new row of matrix (ax) into triangle.
- 210 do 240 i=1,ibandx
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 240
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,ax(irot,1),cos,sin)
-c apply that transformation to the rows of matrix q.
- iq = (irot-1)*my
- do 220 j=1,my
- iq = iq+1
- call fprota(cos,sin,right(j),q(iq))
- 220 continue
-c apply that transformation to the columns of (ax).
- if(i.eq.ibandx) go to 250
- i2 = 1
- i3 = i+1
- do 230 j=i3,ibandx
- i2 = i2+1
- call fprota(cos,sin,h(j),ax(irot,i2))
- 230 continue
- 240 continue
- 250 if(nrold.eq.number) go to 270
- 260 nrold = nrold+1
- go to 150
- 270 continue
-c reduce the matrix (ay) to upper triangular form (ry) using givens
-c rotations. apply the same transformations to the columns of matrix g
-c to obtain the (ny-ky-1) x (nx-kx-1) matrix h.
-c store matrix (ry) into (ay) and h into c.
- ncof = nk1x*nk1y
-c initialization.
- do 280 i=1,ncof
- c(i) = 0.
- 280 continue
- do 290 i=1,nk1y
- do 290 j=1,ky2
- ay(i,j) = 0.
- 290 continue
- nrold = 0
-c ibandy denotes the bandwidth of the matrices (ay) and (ry).
- ibandy = ky1
- do 420 it=1,my
- number = nry(it)
- 300 if(nrold.eq.number) go to 330
- if(p.le.0.) go to 410
- ibandy = ky2
-c fetch a new row of matrix (by).
- n1 = nrold+1
- do 310 j=1,ky2
- h(j) = by(n1,j)*pinv
- 310 continue
-c find the appropiate row of g.
- do 320 j=1,nk1x
- right(j) = 0.
- 320 continue
- irot = nrold
- go to 360
-c fetch a new row of matrix (spy)
- 330 h(ibandy) = 0.
- do 340 j=1,ky1
- h(j) = spy(it,j)
- 340 continue
-c find the appropiate row of g.
- l = it
- do 350 j=1,nk1x
- right(j) = q(l)
- l = l+my
- 350 continue
- irot = number
-c rotate the new row of matrix (ay) into triangle.
- 360 do 390 i=1,ibandy
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 390
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,ay(irot,1),cos,sin)
-c apply that transformation to the colums of matrix g.
- ic = irot
- do 370 j=1,nk1x
- call fprota(cos,sin,right(j),c(ic))
- ic = ic+nk1y
- 370 continue
-c apply that transformation to the columns of matrix (ay).
- if(i.eq.ibandy) go to 400
- i2 = 1
- i3 = i+1
- do 380 j=i3,ibandy
- i2 = i2+1
- call fprota(cos,sin,h(j),ay(irot,i2))
- 380 continue
- 390 continue
- 400 if(nrold.eq.number) go to 420
- 410 nrold = nrold+1
- go to 300
- 420 continue
-c backward substitution to obtain the b-spline coefficients as the
-c solution of the linear system (ry) c (rx)' = h.
-c first step: solve the system (ry) (c1) = h.
- k = 1
- do 450 i=1,nk1x
- call fpback(ay,c(k),nk1y,ibandy,c(k),ny)
- k = k+nk1y
- 450 continue
-c second step: solve the system c (rx)' = (c1).
- k = 0
- do 480 j=1,nk1y
- k = k+1
- l = k
- do 460 i=1,nk1x
- right(i) = c(l)
- l = l+nk1y
- 460 continue
- call fpback(ax,right,nk1x,ibandx,right,nx)
- l = k
- do 470 i=1,nk1x
- c(l) = right(i)
- l = l+nk1y
- 470 continue
- 480 continue
-c calculate the quantities
-c res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my
-c fp = sumi=1,mx(sumj=1,my(res(i,j)))
-c fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1
-c tx(r+kx) <= x(i) <= tx(r+kx+1)
-c fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1
-c ty(r+ky) <= y(j) <= ty(r+ky+1)
- fp = 0.
- do 490 i=1,nx
- fpx(i) = 0.
- 490 continue
- do 500 i=1,ny
- fpy(i) = 0.
- 500 continue
- nk1y = ny-ky1
- iz = 0
- nroldx = 0
-c main loop for the different grid points.
- do 550 i1=1,mx
- numx = nrx(i1)
- numx1 = numx+1
- nroldy = 0
- do 540 i2=1,my
- numy = nry(i2)
- numy1 = numy+1
- iz = iz+1
-c evaluate s(x,y) at the current grid point by making the sum of the
-c cross products of the non-zero b-splines at (x,y), multiplied with
-c the appropiate b-spline coefficients.
- term = 0.
- k1 = numx*nk1y+numy
- do 520 l1=1,kx1
- k2 = k1
- fac = spx(i1,l1)
- do 510 l2=1,ky1
- k2 = k2+1
- term = term+fac*spy(i2,l2)*c(k2)
- 510 continue
- k1 = k1+nk1y
- 520 continue
-c calculate the squared residual at the current grid point.
- term = (z(iz)-term)**2
-c adjust the different parameters.
- fp = fp+term
- fpx(numx1) = fpx(numx1)+term
- fpy(numy1) = fpy(numy1)+term
- fac = term*half
- if(numy.eq.nroldy) go to 530
- fpy(numy1) = fpy(numy1)-fac
- fpy(numy) = fpy(numy)+fac
- 530 nroldy = numy
- if(numx.eq.nroldx) go to 540
- fpx(numx1) = fpx(numx1)-fac
- fpx(numx) = fpx(numx)+fac
- 540 continue
- nroldx = numx
- 550 continue
- return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpgrsp.f
===================================================================
--- branches/Interpolate1D/fitpack/fpgrsp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpgrsp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,656 +0,0 @@
- subroutine fpgrsp(ifsu,ifsv,ifbu,ifbv,iback,u,mu,v,mv,r,mr,dr,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,spu,spv,
- * right,q,au,av1,av2,bu,bv,a0,a1,b0,b1,c0,c1,cosi,nru,nrv)
-c ..
-c ..scalar arguments..
- real*8 p,sq,fp
- integer ifsu,ifsv,ifbu,ifbv,iback,mu,mv,mr,iop0,iop1,nu,nv,nc,
- * mm,mvnu
-c ..array arguments..
- real*8 u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv)
- *,
- * spu(mu,4),spv(mv,4),right(mm),q(mvnu),au(nu,5),av1(nv,6),c0(nv),
- * av2(nv,4),a0(2,mv),b0(2,nv),cosi(2,nv),bu(nu,5),bv(nv,5),c1(nv),
- * a1(2,mv),b1(2,nv)
- integer nru(mu),nrv(mv)
-c ..local scalars..
- real*8 arg,co,dr01,dr02,dr03,dr11,dr12,dr13,fac,fac0,fac1,pinv,piv
- *,
- * si,term,one,three,half
- integer i,ic,ii,ij,ik,iq,irot,it,ir,i0,i1,i2,i3,j,jj,jk,jper,
- * j0,j1,k,k1,k2,l,l0,l1,l2,mvv,ncof,nrold,nroldu,nroldv,number,
- * numu,numu1,numv,numv1,nuu,nu4,nu7,nu8,nu9,nv11,nv4,nv7,nv8,n1
-c ..local arrays..
- real*8 h(5),h1(5),h2(4)
-c ..function references..
- integer min0
- real*8 cos,sin
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpcyt1,fpcyt2,fpdisc,fpbacp,fprota
-c ..
-c let
-c | (spu) | | (spv) |
-c (au) = | -------------- | (av) = | -------------- |
-c | sqrt(1/p) (bu) | | sqrt(1/p) (bv) |
-c
-c | r ' 0 |
-c q = | ------ |
-c | 0 ' 0 |
-c
-c with c : the (nu-4) x (nv-4) matrix which contains the b-spline
-c coefficients.
-c r : the mu x mv matrix which contains the function values.
-c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices
-c according to the least-squares problems in the u-,resp.
-c v-direction.
-c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices
-c containing the discontinuity jumps of the derivatives
-c of the b-splines in the u-,resp.v-variable at the knots
-c the b-spline coefficients of the smoothing spline are then calculated
-c as the least-squares solution of the following over-determined linear
-c system of equations
-c
-c (1) (av) c (au)' = q
-c
-c subject to the constraints
-c
-c (2) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4
-c
-c (3) if iop0 = 0 c(1,j) = dr(1)
-c iop0 = 1 c(1,j) = dr(1)
-c c(2,j) = dr(1)+(dr(2)*cosi(1,j)+dr(3)*cosi(2,j))*
-c tu(5)/3. = c0(j) , j=1,2,...nv-4
-c
-c (4) if iop1 = 0 c(nu-4,j) = dr(4)
-c iop1 = 1 c(nu-4,j) = dr(4)
-c c(nu-5,j) = dr(4)+(dr(5)*cosi(1,j)+dr(6)*cosi(2,j))
-c *(tu(nu-4)-tu(nu-3))/3. = c1(j)
-c
-c set constants
- one = 1
- three = 3
- half = 0.5
-c initialization
- nu4 = nu-4
- nu7 = nu-7
- nu8 = nu-8
- nu9 = nu-9
- nv4 = nv-4
- nv7 = nv-7
- nv8 = nv-8
- nv11 = nv-11
- nuu = nu4-iop0-iop1-2
- if(p.gt.0.) pinv = one/p
-c it depends on the value of the flags ifsu,ifsv,ifbu,ifbv,iop0,iop1
-c and on the value of p whether the matrices (spu), (spv), (bu), (bv),
-c (cosi) still must be determined.
- if(ifsu.ne.0) go to 30
-c calculate the non-zero elements of the matrix (spu) which is the ob-
-c servation matrix according to the least-squares spline approximation
-c problem in the u-direction.
- l = 4
- l1 = 5
- number = 0
- do 25 it=1,mu
- arg = u(it)
- 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 15
- l = l1
- l1 = l+1
- number = number+1
- go to 10
- 15 call fpbspl(tu,nu,3,arg,l,h)
- do 20 i=1,4
- spu(it,i) = h(i)
- 20 continue
- nru(it) = number
- 25 continue
- ifsu = 1
-c calculate the non-zero elements of the matrix (spv) which is the ob-
-c servation matrix according to the least-squares spline approximation
-c problem in the v-direction.
- 30 if(ifsv.ne.0) go to 85
- l = 4
- l1 = 5
- number = 0
- do 50 it=1,mv
- arg = v(it)
- 35 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 40
- l = l1
- l1 = l+1
- number = number+1
- go to 35
- 40 call fpbspl(tv,nv,3,arg,l,h)
- do 45 i=1,4
- spv(it,i) = h(i)
- 45 continue
- nrv(it) = number
- 50 continue
- ifsv = 1
- if(iop0.eq.0 .and. iop1.eq.0) go to 85
-c calculate the coefficients of the interpolating splines for cos(v)
-c and sin(v).
- do 55 i=1,nv4
- cosi(1,i) = 0.
- cosi(2,i) = 0.
- 55 continue
- if(nv7.lt.4) go to 85
- do 65 i=1,nv7
- l = i+3
- arg = tv(l)
- call fpbspl(tv,nv,3,arg,l,h)
- do 60 j=1,3
- av1(i,j) = h(j)
- 60 continue
- cosi(1,i) = cos(arg)
- cosi(2,i) = sin(arg)
- 65 continue
- call fpcyt1(av1,nv7,nv)
- do 80 j=1,2
- do 70 i=1,nv7
- right(i) = cosi(j,i)
- 70 continue
- call fpcyt2(av1,nv7,right,right,nv)
- do 75 i=1,nv7
- cosi(j,i+1) = right(i)
- 75 continue
- cosi(j,1) = cosi(j,nv7+1)
- cosi(j,nv7+2) = cosi(j,2)
- cosi(j,nv4) = cosi(j,3)
- 80 continue
- 85 if(p.le.0.) go to 150
-c calculate the non-zero elements of the matrix (bu).
- if(ifbu.ne.0 .or. nu8.eq.0) go to 90
- call fpdisc(tu,nu,5,bu,nu)
- ifbu = 1
-c calculate the non-zero elements of the matrix (bv).
- 90 if(ifbv.ne.0 .or. nv8.eq.0) go to 150
- call fpdisc(tv,nv,5,bv,nv)
- ifbv = 1
-c substituting (2),(3) and (4) into (1), we obtain the overdetermined
-c system
-c (5) (avv) (cc) (auu)' = (qq)
-c from which the nuu*nv7 remaining coefficients
-c c(i,j) , i=2+iop0,3+iop0,...,nu-5-iop1,j=1,2,...,nv-7.
-c the elements of (cc), are then determined in the least-squares sense.
-c simultaneously, we compute the resulting sum of squared residuals sq.
- 150 dr01 = dr(1)
- dr11 = dr(4)
- do 155 i=1,mv
- a0(1,i) = dr01
- a1(1,i) = dr11
- 155 continue
- if(nv8.eq.0 .or. p.le.0.) go to 165
- do 160 i=1,nv8
- b0(1,i) = 0.
- b1(1,i) = 0.
- 160 continue
- 165 mvv = mv
- if(iop0.eq.0) go to 195
- fac = (tu(5)-tu(4))/three
- dr02 = dr(2)*fac
- dr03 = dr(3)*fac
- do 170 i=1,nv4
- c0(i) = dr01+dr02*cosi(1,i)+dr03*cosi(2,i)
- 170 continue
- do 180 i=1,mv
- number = nrv(i)
- fac = 0.
- do 175 j=1,4
- number = number+1
- fac = fac+c0(number)*spv(i,j)
- 175 continue
- a0(2,i) = fac
- 180 continue
- if(nv8.eq.0 .or. p.le.0.) go to 195
- do 190 i=1,nv8
- number = i
- fac = 0.
- do 185 j=1,5
- fac = fac+c0(number)*bv(i,j)
- number = number+1
- 185 continue
- b0(2,i) = fac*pinv
- 190 continue
- mvv = mv+nv8
- 195 if(iop1.eq.0) go to 225
- fac = (tu(nu4)-tu(nu4+1))/three
- dr12 = dr(5)*fac
- dr13 = dr(6)*fac
- do 200 i=1,nv4
- c1(i) = dr11+dr12*cosi(1,i)+dr13*cosi(2,i)
- 200 continue
- do 210 i=1,mv
- number = nrv(i)
- fac = 0.
- do 205 j=1,4
- number = number+1
- fac = fac+c1(number)*spv(i,j)
- 205 continue
- a1(2,i) = fac
- 210 continue
- if(nv8.eq.0 .or. p.le.0.) go to 225
- do 220 i=1,nv8
- number = i
- fac = 0.
- do 215 j=1,5
- fac = fac+c1(number)*bv(i,j)
- number = number+1
- 215 continue
- b1(2,i) = fac*pinv
- 220 continue
- mvv = mv+nv8
-c we first determine the matrices (auu) and (qq). then we reduce the
-c matrix (auu) to an unit upper triangular form (ru) using givens
-c rotations without square roots. we apply the same transformations to
-c the rows of matrix qq to obtain the mv x nuu matrix g.
-c we store matrix (ru) into au and g into q.
- 225 l = mvv*nuu
-c initialization.
- sq = 0.
- if(l.eq.0) go to 245
- do 230 i=1,l
- q(i) = 0.
- 230 continue
- do 240 i=1,nuu
- do 240 j=1,5
- au(i,j) = 0.
- 240 continue
- l = 0
- 245 nrold = 0
- n1 = nrold+1
- do 420 it=1,mu
- number = nru(it)
-c find the appropriate column of q.
- 250 do 260 j=1,mvv
- right(j) = 0.
- 260 continue
- if(nrold.eq.number) go to 280
- if(p.le.0.) go to 410
-c fetch a new row of matrix (bu).
- do 270 j=1,5
- h(j) = bu(n1,j)*pinv
- 270 continue
- i0 = 1
- i1 = 5
- go to 310
-c fetch a new row of matrix (spu).
- 280 do 290 j=1,4
- h(j) = spu(it,j)
- 290 continue
-c find the appropriate column of q.
- do 300 j=1,mv
- l = l+1
- right(j) = r(l)
- 300 continue
- i0 = 1
- i1 = 4
- 310 j0 = n1
- j1 = nu7-number
-c take into account that we eliminate the constraints (3)
- 315 if(j0-1.gt.iop0) go to 335
- fac0 = h(i0)
- do 320 j=1,mv
- right(j) = right(j)-fac0*a0(j0,j)
- 320 continue
- if(mv.eq.mvv) go to 330
- j = mv
- do 325 jj=1,nv8
- j = j+1
- right(j) = right(j)-fac0*b0(j0,jj)
- 325 continue
- 330 j0 = j0+1
- i0 = i0+1
- go to 315
-c take into account that we eliminate the constraints (4)
- 335 if(j1-1.gt.iop1) go to 360
- fac1 = h(i1)
- do 340 j=1,mv
- right(j) = right(j)-fac1*a1(j1,j)
- 340 continue
- if(mv.eq.mvv) go to 350
- j = mv
- do 345 jj=1,nv8
- j = j+1
- right(j) = right(j)-fac1*b1(j1,jj)
- 345 continue
- 350 j1 = j1+1
- i1 = i1-1
- go to 335
- 360 irot = nrold-iop0-1
- if(irot.lt.0) irot = 0
-c rotate the new row of matrix (auu) into triangle.
- if(i0.gt.i1) go to 390
- do 385 i=i0,i1
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 385
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,au(irot,1),co,si)
-c apply that transformation to the rows of matrix (qq).
- iq = (irot-1)*mvv
- do 370 j=1,mvv
- iq = iq+1
- call fprota(co,si,right(j),q(iq))
- 370 continue
-c apply that transformation to the columns of (auu).
- if(i.eq.i1) go to 385
- i2 = 1
- i3 = i+1
- do 380 j=i3,i1
- i2 = i2+1
- call fprota(co,si,h(j),au(irot,i2))
- 380 continue
- 385 continue
-c we update the sum of squared residuals.
- 390 do 395 j=1,mvv
- sq = sq+right(j)**2
- 395 continue
- 400 if(nrold.eq.number) go to 420
- 410 nrold = n1
- n1 = n1+1
- go to 250
- 420 continue
- if(nuu.eq.0) go to 800
-c we determine the matrix (avv) and then we reduce her to an unit
-c upper triangular form (rv) using givens rotations without square
-c roots. we apply the same transformations to the columns of matrix
-c g to obtain the (nv-7) x (nu-6-iop0-iop1) matrix h.
-c we store matrix (rv) into av1 and av2, h into c.
-c the nv7 x nv7 triangular unit upper matrix (rv) has the form
-c | av1 ' |
-c (rv) = | ' av2 |
-c | 0 ' |
-c with (av2) a nv7 x 4 matrix and (av1) a nv11 x nv11 unit upper
-c triangular matrix of bandwidth 5.
- ncof = nuu*nv7
-c initialization.
- do 430 i=1,ncof
- c(i) = 0.
- 430 continue
- do 440 i=1,nv4
- av1(i,5) = 0.
- do 440 j=1,4
- av1(i,j) = 0.
- av2(i,j) = 0.
- 440 continue
- jper = 0
- nrold = 0
- do 770 it=1,mv
- number = nrv(it)
- 450 if(nrold.eq.number) go to 480
- if(p.le.0.) go to 760
-c fetch a new row of matrix (bv).
- n1 = nrold+1
- do 460 j=1,5
- h(j) = bv(n1,j)*pinv
- 460 continue
-c find the appropiate row of g.
- do 465 j=1,nuu
- right(j) = 0.
- 465 continue
- if(mv.eq.mvv) go to 510
- l = mv+n1
- do 470 j=1,nuu
- right(j) = q(l)
- l = l+mvv
- 470 continue
- go to 510
-c fetch a new row of matrix (spv)
- 480 h(5) = 0.
- do 490 j=1,4
- h(j) = spv(it,j)
- 490 continue
-c find the appropiate row of g.
- l = it
- do 500 j=1,nuu
- right(j) = q(l)
- l = l+mvv
- 500 continue
-c test whether there are non-zero values in the new row of (avv)
-c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4.
- 510 if(nrold.lt.nv11) go to 710
- if(jper.ne.0) go to 550
-c initialize the matrix (av2).
- jk = nv11+1
- do 540 i=1,4
- ik = jk
- do 520 j=1,5
- if(ik.le.0) go to 530
- av2(ik,i) = av1(ik,j)
- ik = ik-1
- 520 continue
- 530 jk = jk+1
- 540 continue
- jper = 1
-c if one of the non-zero elements of the new row corresponds to one of
-c the b-splines n(j;v),j=nv7+1,...,nv4, we take account of condition
-c (2) for setting up this row of (avv). the row is stored in h1( the
-c part with respect to av1) and h2 (the part with respect to av2).
- 550 do 560 i=1,4
- h1(i) = 0.
- h2(i) = 0.
- 560 continue
- h1(5) = 0.
- j = nrold-nv11
- do 600 i=1,5
- j = j+1
- l0 = j
- 570 l1 = l0-4
- if(l1.le.0) go to 590
- if(l1.le.nv11) go to 580
- l0 = l1-nv11
- go to 570
- 580 h1(l1) = h(i)
- go to 600
- 590 h2(l0) = h2(l0) + h(i)
- 600 continue
-c rotate the new row of (avv) into triangle.
- if(nv11.le.0) go to 670
-c rotations with the rows 1,2,...,nv11 of (avv).
- do 660 j=1,nv11
- piv = h1(1)
- i2 = min0(nv11-j,4)
- if(piv.eq.0.) go to 640
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,av1(j,1),co,si)
-c apply that transformation to the columns of matrix g.
- ic = j
- do 610 i=1,nuu
- call fprota(co,si,right(i),c(ic))
- ic = ic+nv7
- 610 continue
-c apply that transformation to the rows of (avv) with respect to av2.
- do 620 i=1,4
- call fprota(co,si,h2(i),av2(j,i))
- 620 continue
-c apply that transformation to the rows of (avv) with respect to av1.
- if(i2.eq.0) go to 670
- do 630 i=1,i2
- i1 = i+1
- call fprota(co,si,h1(i1),av1(j,i1))
- 630 continue
- 640 do 650 i=1,i2
- h1(i) = h1(i+1)
- 650 continue
- h1(i2+1) = 0.
- 660 continue
-c rotations with the rows nv11+1,...,nv7 of avv.
- 670 do 700 j=1,4
- ij = nv11+j
- if(ij.le.0) go to 700
- piv = h2(j)
- if(piv.eq.0.) go to 700
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,av2(ij,j),co,si)
-c apply that transformation to the columns of matrix g.
- ic = ij
- do 680 i=1,nuu
- call fprota(co,si,right(i),c(ic))
- ic = ic+nv7
- 680 continue
- if(j.eq.4) go to 700
-c apply that transformation to the rows of (avv) with respect to av2.
- j1 = j+1
- do 690 i=j1,4
- call fprota(co,si,h2(i),av2(ij,i))
- 690 continue
- 700 continue
-c we update the sum of squared residuals.
- do 705 i=1,nuu
- sq = sq+right(i)**2
- 705 continue
- go to 750
-c rotation into triangle of the new row of (avv), in case the elements
-c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4 are all zero.
- 710 irot =nrold
- do 740 i=1,5
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 740
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,av1(irot,1),co,si)
-c apply that transformation to the columns of matrix g.
- ic = irot
- do 720 j=1,nuu
- call fprota(co,si,right(j),c(ic))
- ic = ic+nv7
- 720 continue
-c apply that transformation to the rows of (avv).
- if(i.eq.5) go to 740
- i2 = 1
- i3 = i+1
- do 730 j=i3,5
- i2 = i2+1
- call fprota(co,si,h(j),av1(irot,i2))
- 730 continue
- 740 continue
-c we update the sum of squared residuals.
- do 745 i=1,nuu
- sq = sq+right(i)**2
- 745 continue
- 750 if(nrold.eq.number) go to 770
- 760 nrold = nrold+1
- go to 450
- 770 continue
-c test whether the b-spline coefficients must be determined.
- if(iback.ne.0) return
-c backward substitution to obtain the b-spline coefficients as the
-c solution of the linear system (rv) (cr) (ru)' = h.
-c first step: solve the system (rv) (c1) = h.
- k = 1
- do 780 i=1,nuu
- call fpbacp(av1,av2,c(k),nv7,4,c(k),5,nv)
- k = k+nv7
- 780 continue
-c second step: solve the system (cr) (ru)' = (c1).
- k = 0
- do 795 j=1,nv7
- k = k+1
- l = k
- do 785 i=1,nuu
- right(i) = c(l)
- l = l+nv7
- 785 continue
- call fpback(au,right,nuu,5,right,nu)
- l = k
- do 790 i=1,nuu
- c(l) = right(i)
- l = l+nv7
- 790 continue
- 795 continue
-c calculate from the conditions (2)-(3)-(4), the remaining b-spline
-c coefficients.
- 800 ncof = nu4*nv4
- j = ncof
- do 805 l=1,nv4
- q(l) = dr01
- q(j) = dr11
- j = j-1
- 805 continue
- i = nv4
- j = 0
- if(iop0.eq.0) go to 815
- do 810 l=1,nv4
- i = i+1
- q(i) = c0(l)
- 810 continue
- 815 if(nuu.eq.0) go to 835
- do 830 l=1,nuu
- ii = i
- do 820 k=1,nv7
- i = i+1
- j = j+1
- q(i) = c(j)
- 820 continue
- do 825 k=1,3
- ii = ii+1
- i = i+1
- q(i) = q(ii)
- 825 continue
- 830 continue
- 835 if(iop1.eq.0) go to 845
- do 840 l=1,nv4
- i = i+1
- q(i) = c1(l)
- 840 continue
- 845 do 850 i=1,ncof
- c(i) = q(i)
- 850 continue
-c calculate the quantities
-c res(i,j) = (r(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv
-c fp = sumi=1,mu(sumj=1,mv(res(i,j)))
-c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7
-c tu(r+3) <= u(i) <= tu(r+4)
-c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7
-c tv(r+3) <= v(j) <= tv(r+4)
- fp = 0.
- do 890 i=1,nu
- fpu(i) = 0.
- 890 continue
- do 900 i=1,nv
- fpv(i) = 0.
- 900 continue
- ir = 0
- nroldu = 0
-c main loop for the different grid points.
- do 950 i1=1,mu
- numu = nru(i1)
- numu1 = numu+1
- nroldv = 0
- do 940 i2=1,mv
- numv = nrv(i2)
- numv1 = numv+1
- ir = ir+1
-c evaluate s(u,v) at the current grid point by making the sum of the
-c cross products of the non-zero b-splines at (u,v), multiplied with
-c the appropiate b-spline coefficients.
- term = 0.
- k1 = numu*nv4+numv
- do 920 l1=1,4
- k2 = k1
- fac = spu(i1,l1)
- do 910 l2=1,4
- k2 = k2+1
- term = term+fac*spv(i2,l2)*c(k2)
- 910 continue
- k1 = k1+nv4
- 920 continue
-c calculate the squared residual at the current grid point.
- term = (r(ir)-term)**2
-c adjust the different parameters.
- fp = fp+term
- fpu(numu1) = fpu(numu1)+term
- fpv(numv1) = fpv(numv1)+term
- fac = term*half
- if(numv.eq.nroldv) go to 930
- fpv(numv1) = fpv(numv1)-fac
- fpv(numv) = fpv(numv)+fac
- 930 nroldv = numv
- if(numu.eq.nroldu) go to 940
- fpu(numu1) = fpu(numu1)-fac
- fpu(numu) = fpu(numu)+fac
- 940 continue
- nroldu = numu
- 950 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpinst.f
===================================================================
--- branches/Interpolate1D/fitpack/fpinst.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpinst.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,77 +0,0 @@
- subroutine fpinst(iopt,t,n,c,k,x,l,tt,nn,cc,nest)
-c given the b-spline representation (knots t(j),j=1,2,...,n, b-spline
-c coefficients c(j),j=1,2,...,n-k-1) of a spline of degree k, fpinst
-c calculates the b-spline representation (knots tt(j),j=1,2,...,nn,
-c b-spline coefficients cc(j),j=1,2,...,nn-k-1) of the same spline if
-c an additional knot is inserted at the point x situated in the inter-
-c val t(l)<=x<t(l+1). iopt denotes whether (iopt.ne.0) or not (iopt=0)
-c the given spline is periodic. in case of a periodic spline at least
-c one of the following conditions must be fulfilled: l>2*k or l<n-2*k.
-c
-c ..scalar arguments..
- integer k,n,l,nn,iopt,nest
- real*8 x
-c ..array arguments..
- real*8 t(nest),c(nest),tt(nest),cc(nest)
-c ..local scalars..
- real*8 fac,per,one
- integer i,i1,j,k1,m,mk,nk,nk1,nl,ll
-c ..
- one = 0.1e+01
- k1 = k+1
- nk1 = n-k1
-c the new knots
- ll = l+1
- i = n
- do 10 j=ll,n
- tt(i+1) = t(i)
- i = i-1
- 10 continue
- tt(ll) = x
- do 20 j=1,l
- tt(j) = t(j)
- 20 continue
-c the new b-spline coefficients
- i = nk1
- do 30 j=l,nk1
- cc(i+1) = c(i)
- i = i-1
- 30 continue
- i = l
- do 40 j=1,k
- m = i+k1
- fac = (x-tt(i))/(tt(m)-tt(i))
- i1 = i-1
- cc(i) = fac*c(i)+(one-fac)*c(i1)
- i = i1
- 40 continue
- do 50 j=1,i
- cc(j) = c(j)
- 50 continue
- nn = n+1
- if(iopt.eq.0) return
-c incorporate the boundary conditions for a periodic spline.
- nk = nn-k
- nl = nk-k1
- per = tt(nk)-tt(k1)
- i = k1
- j = nk
- if(ll.le.nl) go to 70
- do 60 m=1,k
- mk = m+nl
- cc(m) = cc(mk)
- i = i-1
- j = j-1
- tt(i) = tt(j)-per
- 60 continue
- return
- 70 if(ll.gt.(k1+k)) return
- do 80 m=1,k
- mk = m+nl
- cc(mk) = cc(m)
- i = i+1
- j = j+1
- tt(j) = tt(i)+per
- 80 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpintb.f
===================================================================
--- branches/Interpolate1D/fitpack/fpintb.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpintb.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,129 +0,0 @@
- subroutine fpintb(t,n,bint,nk1,x,y)
-c subroutine fpintb calculates integrals of the normalized b-splines
-c nj,k+1(x) of degree k, defined on the set of knots t(j),j=1,2,...n.
-c it makes use of the formulae of gaffney for the calculation of
-c indefinite integrals of b-splines.
-c
-c calling sequence:
-c call fpintb(t,n,bint,nk1,x,y)
-c
-c input parameters:
-c t : real array,length n, containing the position of the knots.
-c n : integer value, giving the number of knots.
-c nk1 : integer value, giving the number of b-splines of degree k,
-c defined on the set of knots ,i.e. nk1 = n-k-1.
-c x,y : real values, containing the end points of the integration
-c interval.
-c output parameter:
-c bint : array,length nk1, containing the integrals of the b-splines.
-c ..
-c ..scalars arguments..
- integer n,nk1
- real*8 x,y
-c ..array arguments..
- real*8 t(n),bint(nk1)
-c ..local scalars..
- integer i,ia,ib,it,j,j1,k,k1,l,li,lj,lk,l0,min
- real*8 a,ak,arg,b,f,one
-c ..local arrays..
- real*8 aint(6),h(6),h1(6)
-c initialization.
- one = 0.1d+01
- k1 = n-nk1
- ak = k1
- k = k1-1
- do 10 i=1,nk1
- bint(i) = 0.0d0
- 10 continue
-c the integration limits are arranged in increasing order.
- a = x
- b = y
- min = 0
- if (a.lt.b) go to 30
- if (a.eq.b) go to 160
- go to 20
- 20 a = y
- b = x
- min = 1
- 30 if(a.lt.t(k1)) a = t(k1)
- if(b.gt.t(nk1+1)) b = t(nk1+1)
-c using the expression of gaffney for the indefinite integral of a
-c b-spline we find that
-c bint(j) = (t(j+k+1)-t(j))*(res(j,b)-res(j,a))/(k+1)
-c where for t(l) <= x < t(l+1)
-c res(j,x) = 0, j=1,2,...,l-k-1
-c = 1, j=l+1,l+2,...,nk1
-c = aint(j+k-l+1), j=l-k,l-k+1,...,l
-c = sumi((x-t(j+i))*nj+i,k+1-i(x)/(t(j+k+1)-t(j+i)))
-c i=0,1,...,k
- l = k1
- l0 = l+1
-c set arg = a.
- arg = a
- do 90 it=1,2
-c search for the knot interval t(l) <= arg < t(l+1).
- 40 if(arg.lt.t(l0) .or. l.eq.nk1) go to 50
- l = l0
- l0 = l+1
- go to 40
-c calculation of aint(j), j=1,2,...,k+1.
-c initialization.
- 50 do 55 j=1,k1
- aint(j) = 0.0d0
- 55 continue
- aint(1) = (arg-t(l))/(t(l+1)-t(l))
- h1(1) = one
- do 70 j=1,k
-c evaluation of the non-zero b-splines of degree j at arg,i.e.
-c h(i+1) = nl-j+i,j(arg), i=0,1,...,j.
- h(1) = 0.0d0
- do 60 i=1,j
- li = l+i
- lj = li-j
- f = h1(i)/(t(li)-t(lj))
- h(i) = h(i)+f*(t(li)-arg)
- h(i+1) = f*(arg-t(lj))
- 60 continue
-c updating of the integrals aint.
- j1 = j+1
- do 70 i=1,j1
- li = l+i
- lj = li-j1
- aint(i) = aint(i)+h(i)*(arg-t(lj))/(t(li)-t(lj))
- h1(i) = h(i)
- 70 continue
- if(it.eq.2) go to 100
-c updating of the integrals bint
- lk = l-k
- ia = lk
- do 80 i=1,k1
- bint(lk) = -aint(i)
- lk = lk+1
- 80 continue
-c set arg = b.
- arg = b
- 90 continue
-c updating of the integrals bint.
- 100 lk = l-k
- ib = lk-1
- do 110 i=1,k1
- bint(lk) = bint(lk)+aint(i)
- lk = lk+1
- 110 continue
- if(ib.lt.ia) go to 130
- do 120 i=ia,ib
- bint(i) = bint(i)+one
- 120 continue
-c the scaling factors are taken into account.
- 130 f = one/ak
- do 140 i=1,nk1
- j = i+k1
- bint(i) = bint(i)*(t(j)-t(i))*f
- 140 continue
-c the order of the integration limits is taken into account.
- if(min.eq.0) go to 160
- do 150 i=1,nk1
- bint(i) = -bint(i)
- 150 continue
- 160 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpknot.f
===================================================================
--- branches/Interpolate1D/fitpack/fpknot.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpknot.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,64 +0,0 @@
- subroutine fpknot(x,m,t,n,fpint,nrdata,nrint,nest,istart)
-c subroutine fpknot locates an additional knot for a spline of degree
-c k and adjusts the corresponding parameters,i.e.
-c t : the position of the knots.
-c n : the number of knots.
-c nrint : the number of knotintervals.
-c fpint : the sum of squares of residual right hand sides
-c for each knot interval.
-c nrdata: the number of data points inside each knot interval.
-c istart indicates that the smallest data point at which the new knot
-c may be added is x(istart+1)
-c ..
-c ..scalar arguments..
- integer m,n,nrint,nest,istart
-c ..array arguments..
- real*8 x(m),t(nest),fpint(nest)
- integer nrdata(nest)
-c ..local scalars..
- real*8 an,am,fpmax
- integer ihalf,j,jbegin,jj,jk,jpoint,k,maxbeg,maxpt,
- * next,nrx,number
-c ..
- k = (n-nrint-1)/2
-c search for knot interval t(number+k) <= x <= t(number+k+1) where
-c fpint(number) is maximal on the condition that nrdata(number)
-c not equals zero.
- fpmax = 0.
- jbegin = istart
- do 20 j=1,nrint
- jpoint = nrdata(j)
- if(fpmax.ge.fpint(j) .or. jpoint.eq.0) go to 10
- fpmax = fpint(j)
- number = j
- maxpt = jpoint
- maxbeg = jbegin
- 10 jbegin = jbegin+jpoint+1
- 20 continue
-c let coincide the new knot t(number+k+1) with a data point x(nrx)
-c inside the old knot interval t(number+k) <= x <= t(number+k+1).
- ihalf = maxpt/2+1
- nrx = maxbeg+ihalf
- next = number+1
- if(next.gt.nrint) go to 40
-c adjust the different parameters.
- do 30 j=next,nrint
- jj = next+nrint-j
- fpint(jj+1) = fpint(jj)
- nrdata(jj+1) = nrdata(jj)
- jk = jj+k
- t(jk+1) = t(jk)
- 30 continue
- 40 nrdata(number) = ihalf-1
- nrdata(next) = maxpt-ihalf
- am = maxpt
- an = nrdata(number)
- fpint(number) = fpmax*an/am
- an = nrdata(next)
- fpint(next) = fpmax*an/am
- jk = next+k
- t(jk) = x(nrx)
- n = n+1
- nrint = nrint+1
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpopdi.f
===================================================================
--- branches/Interpolate1D/fitpack/fpopdi.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpopdi.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,181 +0,0 @@
- subroutine fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,
- * iopt,ider,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpu,fpv,
- * nru,nrv,wrk,lwrk)
-c given the set of function values z(i,j) defined on the rectangular
-c grid (u(i),v(j)),i=1,2,...,mu;j=1,2,...,mv, fpopdi determines a
-c smooth bicubic spline approximation with given knots tu(i),i=1,..,nu
-c in the u-direction and tv(j),j=1,2,...,nv in the v-direction. this
-c spline sp(u,v) will be periodic in the variable v and will satisfy
-c the following constraints
-c
-c s(tu(1),v) = dz(1) , tv(4) <=v<= tv(nv-3)
-c
-c and (if iopt(2) = 1)
-c
-c d s(tu(1),v)
-c ------------ = dz(2)*cos(v)+dz(3)*sin(v) , tv(4) <=v<= tv(nv-3)
-c d u
-c
-c and (if iopt(3) = 1)
-c
-c s(tu(nu),v) = 0 tv(4) <=v<= tv(nv-3)
-c
-c where the parameters dz(i) correspond to the derivative values g(i,j)
-c as defined in subroutine pogrid.
-c
-c the b-spline coefficients of sp(u,v) are determined as the least-
-c squares solution of an overdetermined linear system which depends
-c on the value of p and on the values dz(i),i=1,2,3. the correspond-
-c ing sum of squared residuals sq is a simple quadratic function in
-c the variables dz(i). these may or may not be provided. the values
-c dz(i) which are not given will be determined so as to minimize the
-c resulting sum of squared residuals sq. in that case the user must
-c provide some initial guess dz(i) and some estimate (dz(i)-step,
-c dz(i)+step) of the range of possible values for these latter.
-c
-c sp(u,v) also depends on the parameter p (p>0) in such a way that
-c - if p tends to infinity, sp(u,v) becomes the least-squares spline
-c with given knots, satisfying the constraints.
-c - if p tends to zero, sp(u,v) becomes the least-squares polynomial,
-c satisfying the constraints.
-c - the function f(p)=sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2)
-c is continuous and strictly decreasing for p>0.
-c
-c ..scalar arguments..
- integer ifsu,ifsv,ifbu,ifbv,mu,mv,mz,nu,nv,nuest,nvest,
- * nc,lwrk
- real*8 z0,p,step,fp
-c ..array arguments..
- integer ider(2),nru(mu),nrv(mv),iopt(3)
- real*8 u(mu),v(mv),z(mz),dz(3),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv)
- *,
- * wrk(lwrk)
-c ..local scalars..
- real*8 res,sq,sqq,step1,step2,three
- integer i,id0,iop0,iop1,i1,j,l,laa,lau,lav1,lav2,lbb,lbu,lbv,
- * lcc,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number
-c ..local arrays..
- integer nr(3)
- real*8 delta(3),dzz(3),sum(3),a(6,6),g(6)
-c ..function references..
- integer max0
-c ..subroutine references..
-c fpgrdi,fpsysy
-c ..
-c set constant
- three = 3
-c we partition the working space
- lsu = 1
- lsv = lsu+4*mu
- lri = lsv+4*mv
- mm = max0(nuest,mv+nvest)
- lq = lri+mm
- mvnu = nuest*(mv+nvest-8)
- lau = lq+mvnu
- lav1 = lau+5*nuest
- lav2 = lav1+6*nvest
- lbu = lav2+4*nvest
- lbv = lbu+5*nuest
- laa = lbv+5*nvest
- lbb = laa+2*mv
- lcc = lbb+2*nvest
- lcs = lcc+nvest
-c we calculate the smoothing spline sp(u,v) according to the input
-c values dz(i),i=1,2,3.
- iop0 = iopt(2)
- iop1 = iopt(3)
- call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
- * wrk(lcc),wrk(lcs),nru,nrv)
- id0 = ider(1)
- if(id0.ne.0) go to 5
- res = (z0-dz(1))**2
- fp = fp+res
- sq = sq+res
-c in case all derivative values dz(i) are given (step<=0) or in case
-c we have spline interpolation, we accept this spline as a solution.
- 5 if(step.le.0. .or. sq.le.0.) return
- dzz(1) = dz(1)
- dzz(2) = dz(2)
- dzz(3) = dz(3)
-c number denotes the number of derivative values dz(i) that still must
-c be optimized. let us denote these parameters by g(j),j=1,...,number.
- number = 0
- if(id0.gt.0) go to 10
- number = 1
- nr(1) = 1
- delta(1) = step
- 10 if(iop0.eq.0) go to 20
- if(ider(2).ne.0) go to 20
- step2 = step*three/tu(5)
- nr(number+1) = 2
- nr(number+2) = 3
- delta(number+1) = step2
- delta(number+2) = step2
- number = number+2
- 20 if(number.eq.0) return
-c the sum of squared residuals sq is a quadratic polynomial in the
-c parameters g(j). we determine the unknown coefficients of this
-c polymomial by calculating (number+1)*(number+2)/2 different splines
-c according to specific values for g(j).
- do 30 i=1,number
- l = nr(i)
- step1 = delta(i)
- dzz(l) = dz(l)+step1
- call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
- * wrk(lcc),wrk(lcs),nru,nrv)
- if(id0.eq.0) sum(i) = sum(i)+(z0-dzz(1))**2
- dzz(l) = dz(l)-step1
- call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
- * wrk(lcc),wrk(lcs),nru,nrv)
- if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2
- a(i,i) = (sum(i)+sqq-sq-sq)/step1**2
- if(a(i,i).le.0.) go to 80
- g(i) = (sqq-sum(i))/(step1+step1)
- dzz(l) = dz(l)
- 30 continue
- if(number.eq.1) go to 60
- do 50 i=2,number
- l1 = nr(i)
- step1 = delta(i)
- dzz(l1) = dz(l1)+step1
- i1 = i-1
- do 40 j=1,i1
- l2 = nr(j)
- step2 = delta(j)
- dzz(l2) = dz(l2)+step2
- call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
- * wrk(lcc),wrk(lcs),nru,nrv)
- if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2
- a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2)
- dzz(l2) = dz(l2)
- 40 continue
- dzz(l1) = dz(l1)
- 50 continue
-c the optimal values g(j) are found as the solution of the system
-c d (sq) / d (g(j)) = 0 , j=1,...,number.
- 60 call fpsysy(a,number,g)
- do 70 i=1,number
- l = nr(i)
- dz(l) = dz(l)+g(i)
- 70 continue
-c we determine the spline sp(u,v) according to the optimal values g(j).
- 80 call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
- * wrk(lcc),wrk(lcs),nru,nrv)
- if(id0.eq.0) fp = fp+(z0-dz(1))**2
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpopsp.f
===================================================================
--- branches/Interpolate1D/fitpack/fpopsp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpopsp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,211 +0,0 @@
- subroutine fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,
- * iopt,ider,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpu,fpv,
- * nru,nrv,wrk,lwrk)
-c given the set of function values r(i,j) defined on the rectangular
-c grid (u(i),v(j)),i=1,2,...,mu;j=1,2,...,mv, fpopsp determines a
-c smooth bicubic spline approximation with given knots tu(i),i=1,..,nu
-c in the u-direction and tv(j),j=1,2,...,nv in the v-direction. this
-c spline sp(u,v) will be periodic in the variable v and will satisfy
-c the following constraints
-c
-c s(tu(1),v) = dr(1) , tv(4) <=v<= tv(nv-3)
-c
-c s(tu(nu),v) = dr(4) , tv(4) <=v<= tv(nv-3)
-c
-c and (if iopt(2) = 1)
-c
-c d s(tu(1),v)
-c ------------ = dr(2)*cos(v)+dr(3)*sin(v) , tv(4) <=v<= tv(nv-3)
-c d u
-c
-c and (if iopt(3) = 1)
-c
-c d s(tu(nu),v)
-c ------------- = dr(5)*cos(v)+dr(6)*sin(v) , tv(4) <=v<= tv(nv-3)
-c d u
-c
-c where the parameters dr(i) correspond to the derivative values at the
-c poles as defined in subroutine spgrid.
-c
-c the b-spline coefficients of sp(u,v) are determined as the least-
-c squares solution of an overdetermined linear system which depends
-c on the value of p and on the values dr(i),i=1,...,6. the correspond-
-c ing sum of squared residuals sq is a simple quadratic function in
-c the variables dr(i). these may or may not be provided. the values
-c dr(i) which are not given will be determined so as to minimize the
-c resulting sum of squared residuals sq. in that case the user must
-c provide some initial guess dr(i) and some estimate (dr(i)-step,
-c dr(i)+step) of the range of possible values for these latter.
-c
-c sp(u,v) also depends on the parameter p (p>0) in such a way that
-c - if p tends to infinity, sp(u,v) becomes the least-squares spline
-c with given knots, satisfying the constraints.
-c - if p tends to zero, sp(u,v) becomes the least-squares polynomial,
-c satisfying the constraints.
-c - the function f(p)=sumi=1,mu(sumj=1,mv((r(i,j)-sp(u(i),v(j)))**2)
-c is continuous and strictly decreasing for p>0.
-c
-c ..scalar arguments..
- integer ifsu,ifsv,ifbu,ifbv,mu,mv,mr,nu,nv,nuest,nvest,
- * nc,lwrk
- real*8 r0,r1,p,fp
-c ..array arguments..
- integer ider(4),nru(mu),nrv(mv),iopt(3)
- real*8 u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv)
- *,
- * wrk(lwrk),step(2)
-c ..local scalars..
- real*8 res,sq,sqq,sq0,sq1,step1,step2,three
- integer i,id0,iop0,iop1,i1,j,l,lau,lav1,lav2,la0,la1,lbu,lbv,lb0,
- * lb1,lc0,lc1,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number
-c ..local arrays..
- integer nr(6)
- real*8 delta(6),drr(6),sum(6),a(6,6),g(6)
-c ..function references..
- integer max0
-c ..subroutine references..
-c fpgrsp,fpsysy
-c ..
-c set constant
- three = 3
-c we partition the working space
- lsu = 1
- lsv = lsu+4*mu
- lri = lsv+4*mv
- mm = max0(nuest,mv+nvest)
- lq = lri+mm
- mvnu = nuest*(mv+nvest-8)
- lau = lq+mvnu
- lav1 = lau+5*nuest
- lav2 = lav1+6*nvest
- lbu = lav2+4*nvest
- lbv = lbu+5*nuest
- la0 = lbv+5*nvest
- la1 = la0+2*mv
- lb0 = la1+2*mv
- lb1 = lb0+2*nvest
- lc0 = lb1+2*nvest
- lc1 = lc0+nvest
- lcs = lc1+nvest
-c we calculate the smoothing spline sp(u,v) according to the input
-c values dr(i),i=1,...,6.
- iop0 = iopt(2)
- iop1 = iopt(3)
- id0 = ider(1)
- id1 = ider(3)
- call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
- * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
- sq0 = 0.
- sq1 = 0.
- if(id0.eq.0) sq0 = (r0-dr(1))**2
- if(id1.eq.0) sq1 = (r1-dr(4))**2
- sq = sq+sq0+sq1
-c in case all derivative values dr(i) are given (step<=0) or in case
-c we have spline interpolation, we accept this spline as a solution.
- if(sq.le.0.) return
- if(step(1).le.0. .and. step(2).le.0.) return
- do 10 i=1,6
- drr(i) = dr(i)
- 10 continue
-c number denotes the number of derivative values dr(i) that still must
-c be optimized. let us denote these parameters by g(j),j=1,...,number.
- number = 0
- if(id0.gt.0) go to 20
- number = 1
- nr(1) = 1
- delta(1) = step(1)
- 20 if(iop0.eq.0) go to 30
- if(ider(2).ne.0) go to 30
- step2 = step(1)*three/(tu(5)-tu(4))
- nr(number+1) = 2
- nr(number+2) = 3
- delta(number+1) = step2
- delta(number+2) = step2
- number = number+2
- 30 if(id1.gt.0) go to 40
- number = number+1
- nr(number) = 4
- delta(number) = step(2)
- 40 if(iop1.eq.0) go to 50
- if(ider(4).ne.0) go to 50
- step2 = step(2)*three/(tu(nu)-tu(nu-4))
- nr(number+1) = 5
- nr(number+2) = 6
- delta(number+1) = step2
- delta(number+2) = step2
- number = number+2
- 50 if(number.eq.0) return
-c the sum of squared residulas sq is a quadratic polynomial in the
-c parameters g(j). we determine the unknown coefficients of this
-c polymomial by calculating (number+1)*(number+2)/2 different splines
-c according to specific values for g(j).
- do 60 i=1,number
- l = nr(i)
- step1 = delta(i)
- drr(l) = dr(l)+step1
- call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
- * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
- if(id0.eq.0) sq0 = (r0-drr(1))**2
- if(id1.eq.0) sq1 = (r1-drr(4))**2
- sum(i) = sum(i)+sq0+sq1
- drr(l) = dr(l)-step1
- call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
- * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
- if(id0.eq.0) sq0 = (r0-drr(1))**2
- if(id1.eq.0) sq1 = (r1-drr(4))**2
- sqq = sqq+sq0+sq1
- drr(l) = dr(l)
- a(i,i) = (sum(i)+sqq-sq-sq)/step1**2
- if(a(i,i).le.0.) go to 110
- g(i) = (sqq-sum(i))/(step1+step1)
- 60 continue
- if(number.eq.1) go to 90
- do 80 i=2,number
- l1 = nr(i)
- step1 = delta(i)
- drr(l1) = dr(l1)+step1
- i1 = i-1
- do 70 j=1,i1
- l2 = nr(j)
- step2 = delta(j)
- drr(l2) = dr(l2)+step2
- call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
- * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
- if(id0.eq.0) sq0 = (r0-drr(1))**2
- if(id1.eq.0) sq1 = (r1-drr(4))**2
- sqq = sqq+sq0+sq1
- a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2)
- drr(l2) = dr(l2)
- 70 continue
- drr(l1) = dr(l1)
- 80 continue
-c the optimal values g(j) are found as the solution of the system
-c d (sq) / d (g(j)) = 0 , j=1,...,number.
- 90 call fpsysy(a,number,g)
- do 100 i=1,number
- l = nr(i)
- dr(l) = dr(l)+g(i)
- 100 continue
-c we determine the spline sp(u,v) according to the optimal values g(j).
- 110 call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr,
- * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
- * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
- * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
- * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
- if(id0.eq.0) sq0 = (r0-dr(1))**2
- if(id1.eq.0) sq1 = (r1-dr(4))**2
- sq = sq+sq0+sq1
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fporde.f
===================================================================
--- branches/Interpolate1D/fitpack/fporde.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fporde.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,47 +0,0 @@
- subroutine fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg)
-c subroutine fporde sorts the data points (x(i),y(i)),i=1,2,...,m
-c according to the panel tx(l)<=x<tx(l+1),ty(k)<=y<ty(k+1), they belong
-c to. for each panel a stack is constructed containing the numbers
-c of data points lying inside; index(j),j=1,2,...,nreg points to the
-c first data point in the jth panel while nummer(i),i=1,2,...,m gives
-c the number of the next data point in the panel.
-c ..
-c ..scalar arguments..
- integer m,kx,ky,nx,ny,nreg
-c ..array arguments..
- real*8 x(m),y(m),tx(nx),ty(ny)
- integer nummer(m),index(nreg)
-c ..local scalars..
- real*8 xi,yi
- integer i,im,k,kx1,ky1,k1,l,l1,nk1x,nk1y,num,nyy
-c ..
- kx1 = kx+1
- ky1 = ky+1
- nk1x = nx-kx1
- nk1y = ny-ky1
- nyy = nk1y-ky
- do 10 i=1,nreg
- index(i) = 0
- 10 continue
- do 60 im=1,m
- xi = x(im)
- yi = y(im)
- l = kx1
- l1 = l+1
- 20 if(xi.lt.tx(l1) .or. l.eq.nk1x) go to 30
- l = l1
- l1 = l+1
- go to 20
- 30 k = ky1
- k1 = k+1
- 40 if(yi.lt.ty(k1) .or. k.eq.nk1y) go to 50
- k = k1
- k1 = k+1
- go to 40
- 50 num = (l-kx1)*nyy+k-ky
- nummer(im) = index(num)
- index(num) = im
- 60 continue
- return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fppara.f
===================================================================
--- branches/Interpolate1D/fitpack/fppara.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fppara.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,402 +0,0 @@
- subroutine fppara(iopt,idim,m,u,mx,x,w,ub,ue,k,s,nest,tol,maxit,
- * k1,k2,n,t,nc,c,fp,fpint,z,a,b,g,q,nrdata,ier)
-c ..
-c ..scalar arguments..
- real*8 ub,ue,s,tol,fp
- integer iopt,idim,m,mx,k,nest,maxit,k1,k2,n,nc,ier
-c ..array arguments..
- real*8 u(m),x(mx),w(m),t(nest),c(nc),fpint(nest),
- * z(nc),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1)
- integer nrdata(nest)
-c ..local scalars..
- real*8 acc,con1,con4,con9,cos,fac,fpart,fpms,fpold,fp0,f1,f2,f3,
- * half,one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,ui,wi
- integer i,ich1,ich3,it,iter,i1,i2,i3,j,jj,j1,j2,k3,l,l0,
- * mk1,new,nk1,nmax,nmin,nplus,npl1,nrint,n8
-c ..local arrays..
- real*8 h(7),xi(10)
-c ..function references
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota
-c ..
-c set constants
- one = 0.1e+01
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- half = 0.5e0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position c
-c ************************************************************** c
-c given a set of knots we compute the least-squares curve sinf(u), c
-c and the corresponding sum of squared residuals fp=f(p=inf). c
-c if iopt=-1 sinf(u) is the requested curve. c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares curve until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmax = m+k+1. c
-c if s > 0 and c
-c iopt=0 we first compute the least-squares polynomial curve of c
-c degree k; n = nmin = 2*k+2 c
-c iopt=1 we start with the set of knots found at the last c
-c call of the routine, except for the case that s > fp0; then c
-c we compute directly the polynomial curve of degree k. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c determine nmin, the number of knots for polynomial approximation.
- nmin = 2*k1
- if(iopt.lt.0) go to 60
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c determine nmax, the number of knots for spline interpolation.
- nmax = m+k1
- if(s.gt.0.) go to 45
-c if s=0, s(u) is an interpolating curve.
-c test whether the required storage space exceeds the available one.
- n = nmax
- if(nmax.gt.nest) go to 420
-c find the position of the interior knots in case of interpolation.
- 10 mk1 = m-k1
- if(mk1.eq.0) go to 60
- k3 = k/2
- i = k2
- j = k3+2
- if(k3*2.eq.k) go to 30
- do 20 l=1,mk1
- t(i) = u(j)
- i = i+1
- j = j+1
- 20 continue
- go to 60
- 30 do 40 l=1,mk1
- t(i) = (u(j)+u(j-1))*half
- i = i+1
- j = j+1
- 40 continue
- go to 60
-c if s>0 our initial choice of knots depends on the value of iopt.
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c polynomial curve which is a spline curve without interior knots.
-c if iopt=1 and fp0>s we start computing the least squares spline curve
-c according to the set of knots found at the last call of the routine.
- 45 if(iopt.eq.0) go to 50
- if(n.eq.nmin) go to 50
- fp0 = fpint(n)
- fpold = fpint(n-1)
- nplus = nrdata(n)
- if(fp0.gt.s) go to 60
- 50 n = nmin
- fpold = 0.
- nplus = 0
- nrdata(1) = m-2
-c main loop for the different sets of knots. m is a save upper bound
-c for the number of trials.
- 60 do 200 iter = 1,m
- if(n.eq.nmin) ier = -2
-c find nrint, tne number of knot intervals.
- nrint = n-nmin+1
-c find the position of the additional knots which are needed for
-c the b-spline representation of s(u).
- nk1 = n-k1
- i = n
- do 70 j=1,k1
- t(j) = ub
- t(i) = ue
- i = i-1
- 70 continue
-c compute the b-spline coefficients of the least-squares spline curve
-c sinf(u). the observation matrix a is built up row by row and
-c reduced to upper triangular form by givens transformations.
-c at the same time fp=f(p=inf) is computed.
- fp = 0.
-c initialize the b-spline coefficients and the observation matrix a.
- do 75 i=1,nc
- z(i) = 0.
- 75 continue
- do 80 i=1,nk1
- do 80 j=1,k1
- a(i,j) = 0.
- 80 continue
- l = k1
- jj = 0
- do 130 it=1,m
-c fetch the current data point u(it),x(it).
- ui = u(it)
- wi = w(it)
- do 83 j=1,idim
- jj = jj+1
- xi(j) = x(jj)*wi
- 83 continue
-c search for knot interval t(l) <= ui < t(l+1).
- 85 if(ui.lt.t(l+1) .or. l.eq.nk1) go to 90
- l = l+1
- go to 85
-c evaluate the (k+1) non-zero b-splines at ui and store them in q.
- 90 call fpbspl(t,n,k,ui,l,h)
- do 95 i=1,k1
- q(it,i) = h(i)
- h(i) = h(i)*wi
- 95 continue
-c rotate the new row of the observation matrix into triangle.
- j = l-k1
- do 110 i=1,k1
- j = j+1
- piv = h(i)
- if(piv.eq.0.) go to 110
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(j,1),cos,sin)
-c transformations to right hand side.
- j1 = j
- do 97 j2 =1,idim
- call fprota(cos,sin,xi(j2),z(j1))
- j1 = j1+n
- 97 continue
- if(i.eq.k1) go to 120
- i2 = 1
- i3 = i+1
- do 100 i1 = i3,k1
- i2 = i2+1
-c transformations to left hand side.
- call fprota(cos,sin,h(i1),a(j,i2))
- 100 continue
- 110 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 120 do 125 j2=1,idim
- fp = fp+xi(j2)**2
- 125 continue
- 130 continue
- if(ier.eq.(-2)) fp0 = fp
- fpint(n) = fp0
- fpint(n-1) = fpold
- nrdata(n) = nplus
-c backward substitution to obtain the b-spline coefficients.
- j1 = 1
- do 135 j2=1,idim
- call fpback(a,z(j1),nk1,k1,c(j1),nest)
- j1 = j1+n
- 135 continue
-c test whether the approximation sinf(u) is an acceptable solution.
- if(iopt.lt.0) go to 440
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c if f(p=inf) < s accept the choice of knots.
- if(fpms.lt.0.) go to 250
-c if n = nmax, sinf(u) is an interpolating spline curve.
- if(n.eq.nmax) go to 430
-c increase the number of knots.
-c if n=nest we cannot increase the number of knots because of
-c the storage capacity limitation.
- if(n.eq.nest) go to 420
-c determine the number of knots nplus we are going to add.
- if(ier.eq.0) go to 140
- nplus = 1
- ier = 0
- go to 150
- 140 npl1 = nplus*2
- rn = nplus
- if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp)
- nplus = min0(nplus*2,max0(npl1,nplus/2,1))
- 150 fpold = fp
-c compute the sum of squared residuals for each knot interval
-c t(j+k) <= u(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint.
- fpart = 0.
- i = 1
- l = k2
- new = 0
- jj = 0
- do 180 it=1,m
- if(u(it).lt.t(l) .or. l.gt.nk1) go to 160
- new = 1
- l = l+1
- 160 term = 0.
- l0 = l-k2
- do 175 j2=1,idim
- fac = 0.
- j1 = l0
- do 170 j=1,k1
- j1 = j1+1
- fac = fac+c(j1)*q(it,j)
- 170 continue
- jj = jj+1
- term = term+(w(it)*(fac-x(jj)))**2
- l0 = l0+n
- 175 continue
- fpart = fpart+term
- if(new.eq.0) go to 180
- store = term*half
- fpint(i) = fpart-store
- i = i+1
- fpart = store
- new = 0
- 180 continue
- fpint(nrint) = fpart
- do 190 l=1,nplus
-c add a new knot.
- call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1)
-c if n=nmax we locate the knots as for interpolation
- if(n.eq.nmax) go to 10
-c test whether we cannot further increase the number of knots.
- if(n.eq.nest) go to 200
- 190 continue
-c restart the computations with the new set of knots.
- 200 continue
-c test whether the least-squares kth degree polynomial curve is a
-c solution of our approximation problem.
- 250 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline curve sp(u). c
-c ********************************************************** c
-c we have determined the number of knots and their position. c
-c we now compute the b-spline coefficients of the smoothing curve c
-c sp(u). the observation matrix a is extended by the rows of matrix c
-c b expressing that the kth derivative discontinuities of sp(u) at c
-c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c
-c ponding weights of these additional rows are set to 1/p. c
-c iteratively we then have to determine the value of p such that f(p),c
-c the sum of squared residuals be = s. we already know that the least c
-c squares kth degree polynomial curve corresponds to p=0, and that c
-c the least-squares spline curve corresponds to p=infinity. the c
-c iteration process which is proposed here, makes use of rational c
-c interpolation. since f(p) is a convex and strictly decreasing c
-c function of p, it can be approximated by a rational function c
-c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c
-c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c
-c to calculate the new value of p such that r(p)=s. convergence is c
-c guaranteed by taking f1>0 and f3<0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jump of the kth derivative of the
-c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b.
- call fpdisc(t,n,k2,b,nest)
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = 0.
- do 252 i=1,nk1
- p = p+a(i,1)
- 252 continue
- rn = nk1
- p = rn/p
- ich1 = 0
- ich3 = 0
- n8 = n-nmin
-c iteration process to find the root of f(p) = s.
- do 360 iter=1,maxit
-c the rows of matrix b with weight 1/p are rotated into the
-c triangularised observation matrix a which is stored in g.
- pinv = one/p
- do 255 i=1,nc
- c(i) = z(i)
- 255 continue
- do 260 i=1,nk1
- g(i,k2) = 0.
- do 260 j=1,k1
- g(i,j) = a(i,j)
- 260 continue
- do 300 it=1,n8
-c the row of matrix b is rotated into triangle by givens transformation
- do 270 i=1,k2
- h(i) = b(it,i)*pinv
- 270 continue
- do 275 j=1,idim
- xi(j) = 0.
- 275 continue
- do 290 j=it,nk1
- piv = h(1)
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,g(j,1),cos,sin)
-c transformations to right hand side.
- j1 = j
- do 277 j2=1,idim
- call fprota(cos,sin,xi(j2),c(j1))
- j1 = j1+n
- 277 continue
- if(j.eq.nk1) go to 300
- i2 = k1
- if(j.gt.n8) i2 = nk1-j
- do 280 i=1,i2
-c transformations to left hand side.
- i1 = i+1
- call fprota(cos,sin,h(i1),g(j,i1))
- h(i) = h(i1)
- 280 continue
- h(i2+1) = 0.
- 290 continue
- 300 continue
-c backward substitution to obtain the b-spline coefficients.
- j1 = 1
- do 305 j2=1,idim
- call fpback(g,c(j1),nk1,k2,c(j1),nest)
- j1 =j1+n
- 305 continue
-c computation of f(p).
- fp = 0.
- l = k2
- jj = 0
- do 330 it=1,m
- if(u(it).lt.t(l) .or. l.gt.nk1) go to 310
- l = l+1
- 310 l0 = l-k2
- term = 0.
- do 325 j2=1,idim
- fac = 0.
- j1 = l0
- do 320 j=1,k1
- j1 = j1+1
- fac = fac+c(j1)*q(it,j)
- 320 continue
- jj = jj+1
- term = term+(fac-x(jj))**2
- l0 = l0+n
- 325 continue
- fp = fp+term*w(it)**2
- 330 continue
-c test whether the approximation sp(u) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximal number of iterations is reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 340
- if((f2-f3).gt.acc) go to 335
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p=p1*con9 + p2*con1
- go to 360
- 335 if(f2.lt.0.) ich3=1
- 340 if(ich1.ne.0) go to 350
- if((f1-f2).gt.acc) go to 345
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 360
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 360
- 345 if(f2.gt.0.) ich1=1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 350 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value for p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 360 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- 440 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fppasu.f
===================================================================
--- branches/Interpolate1D/fitpack/fppasu.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fppasu.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,392 +0,0 @@
- subroutine fppasu(iopt,ipar,idim,u,mu,v,mv,z,mz,s,nuest,nvest,
- * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu,
- * fpintv,lastdi,nplusu,nplusv,nru,nrv,nrdatu,nrdatv,wrk,lwrk,ier)
-c ..
-c ..scalar arguments..
- real*8 s,tol,fp,fp0,fpold,reducu,reducv
- integer iopt,idim,mu,mv,mz,nuest,nvest,maxit,nc,nu,nv,lastdi,
- * nplusu,nplusv,lwrk,ier
-c ..array arguments..
- real*8 u(mu),v(mv),z(mz*idim),tu(nuest),tv(nvest),c(nc*idim),
- * fpintu(nuest),fpintv(nvest),wrk(lwrk)
- integer ipar(2),nrdatu(nuest),nrdatv(nvest),nru(mu),nrv(mv)
-c ..local scalars
- real*8 acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,con1,con9,con4,
- * peru,perv,ub,ue,vb,ve
- integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,iter,j,lau1,lav1,laa,
- * l,lau,lav,lbu,lbv,lq,lri,lsu,lsv,l1,l2,l3,l4,mm,mpm,mvnu,ncof,
- * nk1u,nk1v,nmaxu,nmaxv,nminu,nminv,nplu,nplv,npl1,nrintu,
- * nrintv,nue,nuk,nve,nuu,nvv
-c ..function references..
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpgrpa,fpknot
-c ..
-c set constants
- one = 1
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
-c set boundaries of the approximation domain
- ub = u(1)
- ue = u(mu)
- vb = v(1)
- ve = v(mv)
-c we partition the working space.
- lsu = 1
- lsv = lsu+mu*4
- lri = lsv+mv*4
- mm = max0(nuest,mv)
- lq = lri+mm*idim
- mvnu = nuest*mv*idim
- lau = lq+mvnu
- nuk = nuest*5
- lbu = lau+nuk
- lav = lbu+nuk
- nuk = nvest*5
- lbv = lav+nuk
- laa = lbv+nuk
- lau1 = lau
- if(ipar(1).eq.0) go to 10
- peru = ue-ub
- lau1 = laa
- laa = laa+4*nuest
- 10 lav1 = lav
- if(ipar(2).eq.0) go to 20
- perv = ve-vb
- lav1 = laa
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position. c
-c **************************************************************** c
-c given a set of knots we compute the least-squares spline sinf(u,v), c
-c and the corresponding sum of squared residuals fp=f(p=inf). c
-c if iopt=-1 sinf(u,v) is the requested approximation. c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares spline until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmaxu = mu+4+2*ipar(1) and nmaxv = mv+4+2*ipar(2) c
-c if s>0 and c
-c *iopt=0 we first compute the least-squares polynomial c
-c nu=nminu=8 and nv=nminv=8 c
-c *iopt=1 we start with the knots found at the last call of the c
-c routine, except for the case that s > fp0; then we can compute c
-c the least-squares polynomial directly. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c determine the number of knots for polynomial approximation.
- 20 nminu = 8
- nminv = 8
- if(iopt.lt.0) go to 100
-c acc denotes the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c find nmaxu and nmaxv which denote the number of knots in u- and v-
-c direction in case of spline interpolation.
- nmaxu = mu+4+2*ipar(1)
- nmaxv = mv+4+2*ipar(2)
-c find nue and nve which denote the maximum number of knots
-c allowed in each direction
- nue = min0(nmaxu,nuest)
- nve = min0(nmaxv,nvest)
- if(s.gt.0.) go to 60
-c if s = 0, s(u,v) is an interpolating spline.
- nu = nmaxu
- nv = nmaxv
-c test whether the required storage space exceeds the available one.
- if(nv.gt.nvest .or. nu.gt.nuest) go to 420
-c find the position of the interior knots in case of interpolation.
-c the knots in the u-direction.
- nuu = nu-8
- if(nuu.eq.0) go to 40
- i = 5
- j = 3-ipar(1)
- do 30 l=1,nuu
- tu(i) = u(j)
- i = i+1
- j = j+1
- 30 continue
-c the knots in the v-direction.
- 40 nvv = nv-8
- if(nvv.eq.0) go to 60
- i = 5
- j = 3-ipar(2)
- do 50 l=1,nvv
- tv(i) = v(j)
- i = i+1
- j = j+1
- 50 continue
- go to 100
-c if s > 0 our initial choice of knots depends on the value of iopt.
- 60 if(iopt.eq.0) go to 90
- if(fp0.le.s) go to 90
-c if iopt=1 and fp0 > s we start computing the least- squares spline
-c according to the set of knots found at the last call of the routine.
-c we determine the number of grid coordinates u(i) inside each knot
-c interval (tu(l),tu(l+1)).
- l = 5
- j = 1
- nrdatu(1) = 0
- mpm = mu-1
- do 70 i=2,mpm
- nrdatu(j) = nrdatu(j)+1
- if(u(i).lt.tu(l)) go to 70
- nrdatu(j) = nrdatu(j)-1
- l = l+1
- j = j+1
- nrdatu(j) = 0
- 70 continue
-c we determine the number of grid coordinates v(i) inside each knot
-c interval (tv(l),tv(l+1)).
- l = 5
- j = 1
- nrdatv(1) = 0
- mpm = mv-1
- do 80 i=2,mpm
- nrdatv(j) = nrdatv(j)+1
- if(v(i).lt.tv(l)) go to 80
- nrdatv(j) = nrdatv(j)-1
- l = l+1
- j = j+1
- nrdatv(j) = 0
- 80 continue
- go to 100
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c polynomial (which is a spline without interior knots).
- 90 nu = nminu
- nv = nminv
- nrdatu(1) = mu-2
- nrdatv(1) = mv-2
- lastdi = 0
- nplusu = 0
- nplusv = 0
- fp0 = 0.
- fpold = 0.
- reducu = 0.
- reducv = 0.
- 100 mpm = mu+mv
- ifsu = 0
- ifsv = 0
- ifbu = 0
- ifbv = 0
- p = -one
-c main loop for the different sets of knots.mpm=mu+mv is a save upper
-c bound for the number of trials.
- do 250 iter=1,mpm
- if(nu.eq.nminu .and. nv.eq.nminv) ier = -2
-c find nrintu (nrintv) which is the number of knot intervals in the
-c u-direction (v-direction).
- nrintu = nu-nminu+1
- nrintv = nv-nminv+1
-c find ncof, the number of b-spline coefficients for the current set
-c of knots.
- nk1u = nu-4
- nk1v = nv-4
- ncof = nk1u*nk1v
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(u,v).
- if(ipar(1).ne.0) go to 110
- i = nu
- do 105 j=1,4
- tu(j) = ub
- tu(i) = ue
- i = i-1
- 105 continue
- go to 120
- 110 l1 = 4
- l2 = l1
- l3 = nu-3
- l4 = l3
- tu(l2) = ub
- tu(l3) = ue
- do 115 j=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tu(l2) = tu(l4)-peru
- tu(l3) = tu(l1)+peru
- 115 continue
- 120 if(ipar(2).ne.0) go to 130
- i = nv
- do 125 j=1,4
- tv(j) = vb
- tv(i) = ve
- i = i-1
- 125 continue
- go to 140
- 130 l1 = 4
- l2 = l1
- l3 = nv-3
- l4 = l3
- tv(l2) = vb
- tv(l3) = ve
- do 135 j=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tv(l2) = tv(l4)-perv
- tv(l3) = tv(l1)+perv
- 135 continue
-c find the least-squares spline sinf(u,v) and calculate for each knot
-c interval tu(j+3)<=u<=tu(j+4) (tv(j+3)<=v<=tv(j+4)) the sum
-c of squared residuals fpintu(j),j=1,2,...,nu-7 (fpintv(j),j=1,2,...
-c ,nv-7) for the data points having their absciss (ordinate)-value
-c belonging to that interval.
-c fp gives the total sum of squared residuals.
- 140 call fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,tu,
- * nu,tv,nv,p,c,nc,fp,fpintu,fpintv,mm,mvnu,wrk(lsu),wrk(lsv),
- * wrk(lri),wrk(lq),wrk(lau),wrk(lau1),wrk(lav),wrk(lav1),
- * wrk(lbu),wrk(lbv),nru,nrv)
- if(ier.eq.(-2)) fp0 = fp
-c test whether the least-squares spline is an acceptable solution.
- if(iopt.lt.0) go to 440
- fpms = fp-s
- if(abs(fpms) .lt. acc) go to 440
-c if f(p=inf) < s, we accept the choice of knots.
- if(fpms.lt.0.) go to 300
-c if nu=nmaxu and nv=nmaxv, sinf(u,v) is an interpolating spline.
- if(nu.eq.nmaxu .and. nv.eq.nmaxv) go to 430
-c increase the number of knots.
-c if nu=nue and nv=nve we cannot further increase the number of knots
-c because of the storage capacity limitation.
- if(nu.eq.nue .and. nv.eq.nve) go to 420
- ier = 0
-c adjust the parameter reducu or reducv according to the direction
-c in which the last added knots were located.
- if (lastdi.lt.0) go to 150
- if (lastdi.eq.0) go to 170
- go to 160
- 150 reducu = fpold-fp
- go to 170
- 160 reducv = fpold-fp
-c store the sum of squared residuals for the current set of knots.
- 170 fpold = fp
-c find nplu, the number of knots we should add in the u-direction.
- nplu = 1
- if(nu.eq.nminu) go to 180
- npl1 = nplusu*2
- rn = nplusu
- if(reducu.gt.acc) npl1 = rn*fpms/reducu
- nplu = min0(nplusu*2,max0(npl1,nplusu/2,1))
-c find nplv, the number of knots we should add in the v-direction.
- 180 nplv = 1
- if(nv.eq.nminv) go to 190
- npl1 = nplusv*2
- rn = nplusv
- if(reducv.gt.acc) npl1 = rn*fpms/reducv
- nplv = min0(nplusv*2,max0(npl1,nplusv/2,1))
- 190 if (nplu.lt.nplv) go to 210
- if (nplu.eq.nplv) go to 200
- go to 230
- 200 if(lastdi.lt.0) go to 230
- 210 if(nu.eq.nue) go to 230
-c addition in the u-direction.
- lastdi = -1
- nplusu = nplu
- ifsu = 0
- do 220 l=1,nplusu
-c add a new knot in the u-direction
- call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,1)
-c test whether we cannot further increase the number of knots in the
-c u-direction.
- if(nu.eq.nue) go to 250
- 220 continue
- go to 250
- 230 if(nv.eq.nve) go to 210
-c addition in the v-direction.
- lastdi = 1
- nplusv = nplv
- ifsv = 0
- do 240 l=1,nplusv
-c add a new knot in the v-direction.
- call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1)
-c test whether we cannot further increase the number of knots in the
-c v-direction.
- if(nv.eq.nve) go to 250
- 240 continue
-c restart the computations with the new set of knots.
- 250 continue
-c test whether the least-squares polynomial is a solution of our
-c approximation problem.
- 300 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline sp(u,v) c
-c ***************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the b-spline coefficients of the smoothing spline sp(u,v). c
-c this smoothing spline varies with the parameter p in such a way thatc
-c f(p)=suml=1,idim(sumi=1,mu(sumj=1,mv((z(i,j,l)-sp(u(i),v(j),l))**2) c
-c is a continuous, strictly decreasing function of p. moreover the c
-c least-squares polynomial corresponds to p=0 and the least-squares c
-c spline to p=infinity. iteratively we then have to determine the c
-c positive value of p such that f(p)=s. the process which is proposed c
-c here makes use of rational interpolation. f(p) is approximated by a c
-c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c
-c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c
-c are used to calculate the new value of p such that r(p)=s. c
-c convergence is guaranteed by taking f1 > 0 and f3 < 0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = one
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p)=s.
- do 350 iter = 1,maxit
-c find the smoothing spline sp(u,v) and the corresponding sum of
-c squared residuals fp.
- call fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,tu,
- * nu,tv,nv,p,c,nc,fp,fpintu,fpintv,mm,mvnu,wrk(lsu),wrk(lsv),
- * wrk(lri),wrk(lq),wrk(lau),wrk(lau1),wrk(lav),wrk(lav1),
- * wrk(lbu),wrk(lbv),nru,nrv)
-c test whether the approximation sp(u,v) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 320
- if((f2-f3).gt.acc) go to 310
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 350
- 310 if(f2.lt.0.) ich3 = 1
- 320 if(ich1.ne.0) go to 340
- if((f1-f2).gt.acc) go to 330
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 350
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 350
-c test whether the iteration process proceeds as theoretically
-c expected.
- 330 if(f2.gt.0.) ich1 = 1
- 340 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 350 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- fp = 0.
- 440 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpperi.f
===================================================================
--- branches/Interpolate1D/fitpack/fpperi.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpperi.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,616 +0,0 @@
- subroutine fpperi(iopt,x,y,w,m,k,s,nest,tol,maxit,k1,k2,n,t,c,
- * fp,fpint,z,a1,a2,b,g1,g2,q,nrdata,ier)
-c ..
-c ..scalar arguments..
- real*8 s,tol,fp
- integer iopt,m,k,nest,maxit,k1,k2,n,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),t(nest),c(nest),fpint(nest),z(nest),
- * a1(nest,k1),a2(nest,k),b(nest,k2),g1(nest,k2),g2(nest,k1),
- * q(m,k1)
- integer nrdata(nest)
-c ..local scalars..
- real*8 acc,cos,c1,d1,fpart,fpms,fpold,fp0,f1,f2,f3,p,per,pinv,piv,
- *
- * p1,p2,p3,sin,store,term,wi,xi,yi,rn,one,con1,con4,con9,half
- integer i,ich1,ich3,ij,ik,it,iter,i1,i2,i3,j,jk,jper,j1,j2,kk,
- * kk1,k3,l,l0,l1,l5,mm,m1,new,nk1,nk2,nmax,nmin,nplus,npl1,
- * nrint,n10,n11,n7,n8
-c ..local arrays..
- real*8 h(6),h1(7),h2(6)
-c ..function references..
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota
-c ..
-c set constants
- one = 0.1e+01
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- half = 0.5e0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position c
-c ************************************************************** c
-c given a set of knots we compute the least-squares periodic spline c
-c sinf(x). if the sum f(p=inf) <= s we accept the choice of knots. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmax = m+2*k. c
-c if s > 0 and c
-c iopt=0 we first compute the least-squares polynomial of c
-c degree k; n = nmin = 2*k+2. since s(x) must be periodic we c
-c find that s(x) is a constant function. c
-c iopt=1 we start with the set of knots found at the last c
-c call of the routine, except for the case that s > fp0; then c
-c we compute directly the least-squares periodic polynomial. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- m1 = m-1
- kk = k
- kk1 = k1
- k3 = 3*k+1
- nmin = 2*k1
-c determine the length of the period of s(x).
- per = x(m)-x(1)
- if(iopt.lt.0) go to 50
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c determine nmax, the number of knots for periodic spline interpolation
- nmax = m+2*k
- if(s.gt.0. .or. nmax.eq.nmin) go to 30
-c if s=0, s(x) is an interpolating spline.
- n = nmax
-c test whether the required storage space exceeds the available one.
- if(n.gt.nest) go to 620
-c find the position of the interior knots in case of interpolation.
- 5 if((k/2)*2 .eq. k) go to 20
- do 10 i=2,m1
- j = i+k
- t(j) = x(i)
- 10 continue
- if(s.gt.0.) go to 50
- kk = k-1
- kk1 = k
- if(kk.gt.0) go to 50
- t(1) = t(m)-per
- t(2) = x(1)
- t(m+1) = x(m)
- t(m+2) = t(3)+per
- do 15 i=1,m1
- c(i) = y(i)
- 15 continue
- c(m) = c(1)
- fp = 0.
- fpint(n) = fp0
- fpint(n-1) = 0.
- nrdata(n) = 0
- go to 630
- 20 do 25 i=2,m1
- j = i+k
- t(j) = (x(i)+x(i-1))*half
- 25 continue
- go to 50
-c if s > 0 our initial choice depends on the value of iopt.
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c periodic polynomial. (i.e. a constant function).
-c if iopt=1 and fp0>s we start computing the least-squares periodic
-c spline according the set of knots found at the last call of the
-c routine.
- 30 if(iopt.eq.0) go to 35
- if(n.eq.nmin) go to 35
- fp0 = fpint(n)
- fpold = fpint(n-1)
- nplus = nrdata(n)
- if(fp0.gt.s) go to 50
-c the case that s(x) is a constant function is treated separetely.
-c find the least-squares constant c1 and compute fp0 at the same time.
- 35 fp0 = 0.
- d1 = 0.
- c1 = 0.
- do 40 it=1,m1
- wi = w(it)
- yi = y(it)*wi
- call fpgivs(wi,d1,cos,sin)
- call fprota(cos,sin,yi,c1)
- fp0 = fp0+yi**2
- 40 continue
- c1 = c1/d1
-c test whether that constant function is a solution of our problem.
- fpms = fp0-s
- if(fpms.lt.acc .or. nmax.eq.nmin) go to 640
- fpold = fp0
-c test whether the required storage space exceeds the available one.
- if(nmin.ge.nest) go to 620
-c start computing the least-squares periodic spline with one
-c interior knot.
- nplus = 1
- n = nmin+1
- mm = (m+1)/2
- t(k2) = x(mm)
- nrdata(1) = mm-2
- nrdata(2) = m1-mm
-c main loop for the different sets of knots. m is a save upper
-c bound for the number of trials.
- 50 do 340 iter=1,m
-c find nrint, the number of knot intervals.
- nrint = n-nmin+1
-c find the position of the additional knots which are needed for
-c the b-spline representation of s(x). if we take
-c t(k+1) = x(1), t(n-k) = x(m)
-c t(k+1-j) = t(n-k-j) - per, j=1,2,...k
-c t(n-k+j) = t(k+1+j) + per, j=1,2,...k
-c then s(x) is a periodic spline with period per if the b-spline
-c coefficients satisfy the following conditions
-c c(n7+j) = c(j), j=1,...k (**) with n7=n-2*k-1.
- t(k1) = x(1)
- nk1 = n-k1
- nk2 = nk1+1
- t(nk2) = x(m)
- do 60 j=1,k
- i1 = nk2+j
- i2 = nk2-j
- j1 = k1+j
- j2 = k1-j
- t(i1) = t(j1)+per
- t(j2) = t(i2)-per
- 60 continue
-c compute the b-spline coefficients c(j),j=1,...n7 of the least-squares
-c periodic spline sinf(x). the observation matrix a is built up row
-c by row while taking into account condition (**) and is reduced to
-c triangular form by givens transformations .
-c at the same time fp=f(p=inf) is computed.
-c the n7 x n7 triangularised upper matrix a has the form
-c ! a1 ' !
-c a = ! ' a2 !
-c ! 0 ' !
-c with a2 a n7 x k matrix and a1 a n10 x n10 upper triangular
-c matrix of bandwith k+1 ( n10 = n7-k).
-c initialization.
- do 70 i=1,nk1
- z(i) = 0.
- do 70 j=1,kk1
- a1(i,j) = 0.
- 70 continue
- n7 = nk1-k
- n10 = n7-kk
- jper = 0
- fp = 0.
- l = k1
- do 290 it=1,m1
-c fetch the current data point x(it),y(it)
- xi = x(it)
- wi = w(it)
- yi = y(it)*wi
-c search for knot interval t(l) <= xi < t(l+1).
- 80 if(xi.lt.t(l+1)) go to 85
- l = l+1
- go to 80
-c evaluate the (k+1) non-zero b-splines at xi and store them in q.
- 85 call fpbspl(t,n,k,xi,l,h)
- do 90 i=1,k1
- q(it,i) = h(i)
- h(i) = h(i)*wi
- 90 continue
- l5 = l-k1
-c test whether the b-splines nj,k+1(x),j=1+n7,...nk1 are all zero at xi
- if(l5.lt.n10) go to 285
- if(jper.ne.0) go to 160
-c initialize the matrix a2.
- do 95 i=1,n7
- do 95 j=1,kk
- a2(i,j) = 0.
- 95 continue
- jk = n10+1
- do 110 i=1,kk
- ik = jk
- do 100 j=1,kk1
- if(ik.le.0) go to 105
- a2(ik,i) = a1(ik,j)
- ik = ik-1
- 100 continue
- 105 jk = jk+1
- 110 continue
- jper = 1
-c if one of the b-splines nj,k+1(x),j=n7+1,...nk1 is not zero at xi
-c we take account of condition (**) for setting up the new row
-c of the observation matrix a. this row is stored in the arrays h1
-c (the part with respect to a1) and h2 (the part with
-c respect to a2).
- 160 do 170 i=1,kk
- h1(i) = 0.
- h2(i) = 0.
- 170 continue
- h1(kk1) = 0.
- j = l5-n10
- do 210 i=1,kk1
- j = j+1
- l0 = j
- 180 l1 = l0-kk
- if(l1.le.0) go to 200
- if(l1.le.n10) go to 190
- l0 = l1-n10
- go to 180
- 190 h1(l1) = h(i)
- go to 210
- 200 h2(l0) = h2(l0)+h(i)
- 210 continue
-c rotate the new row of the observation matrix into triangle
-c by givens transformations.
- if(n10.le.0) go to 250
-c rotation with the rows 1,2,...n10 of matrix a.
- do 240 j=1,n10
- piv = h1(1)
- if(piv.ne.0.) go to 214
- do 212 i=1,kk
- h1(i) = h1(i+1)
- 212 continue
- h1(kk1) = 0.
- go to 240
-c calculate the parameters of the givens transformation.
- 214 call fpgivs(piv,a1(j,1),cos,sin)
-c transformation to the right hand side.
- call fprota(cos,sin,yi,z(j))
-c transformations to the left hand side with respect to a2.
- do 220 i=1,kk
- call fprota(cos,sin,h2(i),a2(j,i))
- 220 continue
- if(j.eq.n10) go to 250
- i2 = min0(n10-j,kk)
-c transformations to the left hand side with respect to a1.
- do 230 i=1,i2
- i1 = i+1
- call fprota(cos,sin,h1(i1),a1(j,i1))
- h1(i) = h1(i1)
- 230 continue
- h1(i1) = 0.
- 240 continue
-c rotation with the rows n10+1,...n7 of matrix a.
- 250 do 270 j=1,kk
- ij = n10+j
- if(ij.le.0) go to 270
- piv = h2(j)
- if(piv.eq.0.) go to 270
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a2(ij,j),cos,sin)
-c transformations to right hand side.
- call fprota(cos,sin,yi,z(ij))
- if(j.eq.kk) go to 280
- j1 = j+1
-c transformations to left hand side.
- do 260 i=j1,kk
- call fprota(cos,sin,h2(i),a2(ij,i))
- 260 continue
- 270 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 280 fp = fp+yi**2
- go to 290
-c rotation of the new row of the observation matrix into
-c triangle in case the b-splines nj,k+1(x),j=n7+1,...n-k-1 are all zero
-c at xi.
- 285 j = l5
- do 140 i=1,kk1
- j = j+1
- piv = h(i)
- if(piv.eq.0.) go to 140
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a1(j,1),cos,sin)
-c transformations to right hand side.
- call fprota(cos,sin,yi,z(j))
- if(i.eq.kk1) go to 150
- i2 = 1
- i3 = i+1
-c transformations to left hand side.
- do 130 i1=i3,kk1
- i2 = i2+1
- call fprota(cos,sin,h(i1),a1(j,i2))
- 130 continue
- 140 continue
-c add contribution of this row to the sum of squares of residual
-c right hand sides.
- 150 fp = fp+yi**2
- 290 continue
- fpint(n) = fp0
- fpint(n-1) = fpold
- nrdata(n) = nplus
-c backward substitution to obtain the b-spline coefficients c(j),j=1,.n
- call fpbacp(a1,a2,z,n7,kk,c,kk1,nest)
-c calculate from condition (**) the coefficients c(j+n7),j=1,2,...k.
- do 295 i=1,k
- j = i+n7
- c(j) = c(i)
- 295 continue
- if(iopt.lt.0) go to 660
-c test whether the approximation sinf(x) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 660
-c if f(p=inf) < s accept the choice of knots.
- if(fpms.lt.0.) go to 350
-c if n=nmax, sinf(x) is an interpolating spline.
- if(n.eq.nmax) go to 630
-c increase the number of knots.
-c if n=nest we cannot increase the number of knots because of the
-c storage capacity limitation.
- if(n.eq.nest) go to 620
-c determine the number of knots nplus we are going to add.
- npl1 = nplus*2
- rn = nplus
- if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp)
- nplus = min0(nplus*2,max0(npl1,nplus/2,1))
- fpold = fp
-c compute the sum(wi*(yi-s(xi))**2) for each knot interval
-c t(j+k) <= xi <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint.
- fpart = 0.
- i = 1
- l = k1
- do 320 it=1,m1
- if(x(it).lt.t(l)) go to 300
- new = 1
- l = l+1
- 300 term = 0.
- l0 = l-k2
- do 310 j=1,k1
- l0 = l0+1
- term = term+c(l0)*q(it,j)
- 310 continue
- term = (w(it)*(term-y(it)))**2
- fpart = fpart+term
- if(new.eq.0) go to 320
- if(l.gt.k2) go to 315
- fpint(nrint) = term
- new = 0
- go to 320
- 315 store = term*half
- fpint(i) = fpart-store
- i = i+1
- fpart = store
- new = 0
- 320 continue
- fpint(nrint) = fpint(nrint)+fpart
- do 330 l=1,nplus
-c add a new knot
- call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1)
-c if n=nmax we locate the knots as for interpolation.
- if(n.eq.nmax) go to 5
-c test whether we cannot further increase the number of knots.
- if(n.eq.nest) go to 340
- 330 continue
-c restart the computations with the new set of knots.
- 340 continue
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing periodic spline sp(x). c
-c ************************************************************* c
-c we have determined the number of knots and their position. c
-c we now compute the b-spline coefficients of the smoothing spline c
-c sp(x). the observation matrix a is extended by the rows of matrix c
-c b expressing that the kth derivative discontinuities of sp(x) at c
-c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c
-c ponding weights of these additional rows are set to 1/sqrt(p). c
-c iteratively we then have to determine the value of p such that c
-c f(p)=sum(w(i)*(y(i)-sp(x(i)))**2) be = s. we already know that c
-c the least-squares constant function corresponds to p=0, and that c
-c the least-squares periodic spline corresponds to p=infinity. the c
-c iteration process which is proposed here, makes use of rational c
-c interpolation. since f(p) is a convex and strictly decreasing c
-c function of p, it can be approximated by a rational function c
-c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c
-c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c
-c to calculate the new value of p such that r(p)=s. convergence is c
-c guaranteed by taking f1>0 and f3<0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jump of the kth derivative of the
-c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b.
- 350 call fpdisc(t,n,k2,b,nest)
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- n11 = n10-1
- n8 = n7-1
- p = 0.
- l = n7
- do 352 i=1,k
- j = k+1-i
- p = p+a2(l,j)
- l = l-1
- if(l.eq.0) go to 356
- 352 continue
- do 354 i=1,n10
- p = p+a1(i,1)
- 354 continue
- 356 rn = n7
- p = rn/p
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p) = s.
- do 595 iter=1,maxit
-c form the matrix g as the matrix a extended by the rows of matrix b.
-c the rows of matrix b with weight 1/p are rotated into
-c the triangularised observation matrix a.
-c after triangularisation our n7 x n7 matrix g takes the form
-c ! g1 ' !
-c g = ! ' g2 !
-c ! 0 ' !
-c with g2 a n7 x (k+1) matrix and g1 a n11 x n11 upper triangular
-c matrix of bandwidth k+2. ( n11 = n7-k-1)
- pinv = one/p
-c store matrix a into g
- do 360 i=1,n7
- c(i) = z(i)
- g1(i,k1) = a1(i,k1)
- g1(i,k2) = 0.
- g2(i,1) = 0.
- do 360 j=1,k
- g1(i,j) = a1(i,j)
- g2(i,j+1) = a2(i,j)
- 360 continue
- l = n10
- do 370 j=1,k1
- if(l.le.0) go to 375
- g2(l,1) = a1(l,j)
- l = l-1
- 370 continue
- 375 do 540 it=1,n8
-c fetch a new row of matrix b and store it in the arrays h1 (the part
-c with respect to g1) and h2 (the part with respect to g2).
- yi = 0.
- do 380 i=1,k1
- h1(i) = 0.
- h2(i) = 0.
- 380 continue
- h1(k2) = 0.
- if(it.gt.n11) go to 420
- l = it
- l0 = it
- do 390 j=1,k2
- if(l0.eq.n10) go to 400
- h1(j) = b(it,j)*pinv
- l0 = l0+1
- 390 continue
- go to 470
- 400 l0 = 1
- do 410 l1=j,k2
- h2(l0) = b(it,l1)*pinv
- l0 = l0+1
- 410 continue
- go to 470
- 420 l = 1
- i = it-n10
- do 460 j=1,k2
- i = i+1
- l0 = i
- 430 l1 = l0-k1
- if(l1.le.0) go to 450
- if(l1.le.n11) go to 440
- l0 = l1-n11
- go to 430
- 440 h1(l1) = b(it,j)*pinv
- go to 460
- 450 h2(l0) = h2(l0)+b(it,j)*pinv
- 460 continue
- if(n11.le.0) go to 510
-c rotate this row into triangle by givens transformations without
-c square roots.
-c rotation with the rows l,l+1,...n11.
- 470 do 500 j=l,n11
- piv = h1(1)
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,g1(j,1),cos,sin)
-c transformation to right hand side.
- call fprota(cos,sin,yi,c(j))
-c transformation to the left hand side with respect to g2.
- do 480 i=1,k1
- call fprota(cos,sin,h2(i),g2(j,i))
- 480 continue
- if(j.eq.n11) go to 510
- i2 = min0(n11-j,k1)
-c transformation to the left hand side with respect to g1.
- do 490 i=1,i2
- i1 = i+1
- call fprota(cos,sin,h1(i1),g1(j,i1))
- h1(i) = h1(i1)
- 490 continue
- h1(i1) = 0.
- 500 continue
-c rotation with the rows n11+1,...n7
- 510 do 530 j=1,k1
- ij = n11+j
- if(ij.le.0) go to 530
- piv = h2(j)
-c calculate the parameters of the givens transformation
- call fpgivs(piv,g2(ij,j),cos,sin)
-c transformation to the right hand side.
- call fprota(cos,sin,yi,c(ij))
- if(j.eq.k1) go to 540
- j1 = j+1
-c transformation to the left hand side.
- do 520 i=j1,k1
- call fprota(cos,sin,h2(i),g2(ij,i))
- 520 continue
- 530 continue
- 540 continue
-c backward substitution to obtain the b-spline coefficients
-c c(j),j=1,2,...n7 of sp(x).
- call fpbacp(g1,g2,c,n7,k1,c,k2,nest)
-c calculate from condition (**) the b-spline coefficients c(n7+j),j=1,.
- do 545 i=1,k
- j = i+n7
- c(j) = c(i)
- 545 continue
-c computation of f(p).
- fp = 0.
- l = k1
- do 570 it=1,m1
- if(x(it).lt.t(l)) go to 550
- l = l+1
- 550 l0 = l-k2
- term = 0.
- do 560 j=1,k1
- l0 = l0+1
- term = term+c(l0)*q(it,j)
- 560 continue
- fp = fp+(w(it)*(term-y(it)))**2
- 570 continue
-c test whether the approximation sp(x) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 660
-c test whether the maximal number of iterations is reached.
- if(iter.eq.maxit) go to 600
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 580
- if((f2-f3) .gt. acc) go to 575
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 +p2*con1
- go to 595
- 575 if(f2.lt.0.) ich3 = 1
- 580 if(ich1.ne.0) go to 590
- if((f1-f2) .gt. acc) go to 585
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 595
- if(p.ge.p3) p = p2*con1 +p3*con9
- go to 595
- 585 if(f2.gt.0.) ich1 = 1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 590 if(f2.ge.f1 .or. f2.le.f3) go to 610
-c find the new value for p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 595 continue
-c error codes and messages.
- 600 ier = 3
- go to 660
- 610 ier = 2
- go to 660
- 620 ier = 1
- go to 660
- 630 ier = -1
- go to 660
- 640 ier = -2
-c the least-squares constant function c1 is a solution of our problem.
-c a constant function is a spline of degree k with all b-spline
-c coefficients equal to that constant c1.
- do 650 i=1,k1
- rn = k1-i
- t(i) = x(1)-rn*per
- c(i) = c1
- j = i+k1
- rn = i-1
- t(j) = x(m)+rn*per
- 650 continue
- n = nmin
- fp = fp0
- fpint(n) = fp0
- fpint(n-1) = 0.
- nrdata(n) = 0
- 660 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fppocu.f
===================================================================
--- branches/Interpolate1D/fitpack/fppocu.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fppocu.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,72 +0,0 @@
- subroutine fppocu(idim,k,a,b,ib,db,nb,ie,de,ne,cp,np)
-c subroutine fppocu finds a idim-dimensional polynomial curve p(u) =
-c (p1(u),p2(u),...,pidim(u)) of degree k, satisfying certain derivative
-c constraints at the end points a and b, i.e.
-c (l)
-c if ib > 0 : pj (a) = db(idim*l+j), l=0,1,...,ib-1
-c (l)
-c if ie > 0 : pj (b) = de(idim*l+j), l=0,1,...,ie-1
-c
-c the polynomial curve is returned in its b-spline representation
-c ( coefficients cp(j), j=1,2,...,np )
-c ..
-c ..scalar arguments..
- integer idim,k,ib,nb,ie,ne,np
- real*8 a,b
-c ..array arguments..
- real*8 db(nb),de(ne),cp(np)
-c ..local scalars..
- real*8 ab,aki
- integer i,id,j,jj,l,ll,k1,k2
-c ..local array..
- real*8 work(6,6)
-c ..
- k1 = k+1
- k2 = 2*k1
- ab = b-a
- do 110 id=1,idim
- do 10 j=1,k1
- work(j,1) = 0.
- 10 continue
- if(ib.eq.0) go to 50
- l = id
- do 20 i=1,ib
- work(1,i) = db(l)
- l = l+idim
- 20 continue
- if(ib.eq.1) go to 50
- ll = ib
- do 40 j=2,ib
- ll = ll-1
- do 30 i=1,ll
- aki = k1-i
- work(j,i) = ab*work(j-1,i+1)/aki + work(j-1,i)
- 30 continue
- 40 continue
- 50 if(ie.eq.0) go to 90
- l = id
- j = k1
- do 60 i=1,ie
- work(j,i) = de(l)
- l = l+idim
- j = j-1
- 60 continue
- if(ie.eq.1) go to 90
- ll = ie
- do 80 jj=2,ie
- ll = ll-1
- j = k1+1-jj
- do 70 i=1,ll
- aki = k1-i
- work(j,i) = work(j+1,i) - ab*work(j,i+1)/aki
- j = j-1
- 70 continue
- 80 continue
- 90 l = (id-1)*k2
- do 100 j=1,k1
- l = l+1
- cp(l) = work(j,1)
- 100 continue
- 110 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fppogr.f
===================================================================
--- branches/Interpolate1D/fitpack/fppogr.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fppogr.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,410 +0,0 @@
- subroutine fppogr(iopt,ider,u,mu,v,mv,z,mz,z0,r,s,nuest,nvest,
- * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu,
- * fpintv,dz,step,lastdi,nplusu,nplusv,lasttu,nru,nrv,nrdatu,
- * nrdatv,wrk,lwrk,ier)
-c ..
-c ..scalar arguments..
- integer mu,mv,mz,nuest,nvest,maxit,nc,nu,nv,lastdi,nplusu,nplusv,
- * lasttu,lwrk,ier
- real*8 z0,r,s,tol,fp,fp0,fpold,reducu,reducv,step
-c ..array arguments..
- integer iopt(3),ider(2),nrdatu(nuest),nrdatv(nvest),nru(mu),
- * nrv(mv)
- real*8 u(mu),v(mv),z(mz),tu(nuest),tv(nvest),c(nc),fpintu(nuest),
- * fpintv(nvest),dz(3),wrk(lwrk)
-c ..local scalars..
- real*8 acc,fpms,f1,f2,f3,p,per,pi,p1,p2,p3,vb,ve,zmax,zmin,rn,one,
- *
- * con1,con4,con9
- integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,istart,iter,i1,i2,j,ju,
- * ktu,l,l1,l2,l3,l4,mpm,mumin,mu0,mu1,nn,nplu,nplv,npl1,nrintu,
- * nrintv,nue,numax,nve,nvmax
-c ..local arrays..
- integer idd(2)
- real*8 dzz(3)
-c ..function references..
- real*8 abs,datan2,fprati
- integer max0,min0
-c ..subroutine references..
-c fpknot,fpopdi
-c ..
-c set constants
- one = 1d0
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
-c initialization
- ifsu = 0
- ifsv = 0
- ifbu = 0
- ifbv = 0
- p = -one
- mumin = 4-iopt(3)
- if(ider(1).ge.0) mumin = mumin-1
- if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1
- pi = datan2(0d0,-one)
- per = pi+pi
- vb = v(1)
- ve = vb+per
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position. c
-c **************************************************************** c
-c given a set of knots we compute the least-squares spline sinf(u,v) c
-c and the corresponding sum of squared residuals fp = f(p=inf). c
-c if iopt(1)=-1 sinf(u,v) is the requested approximation. c
-c if iopt(1)>=0 we check whether we can accept the knots: c
-c if fp <= s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares spline until finally fp <= s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots in the u-direction equals nu=numax=mu+5+iopt(2)+iopt(3) c
-c and in the v-direction nv=nvmax=mv+7. c
-c if s>0 and c
-c iopt(1)=0 we first compute the least-squares polynomial,i.e. a c
-c spline without interior knots : nu=8 ; nv=8. c
-c iopt(1)=1 we start with the set of knots found at the last call c
-c of the routine, except for the case that s > fp0; then we c
-c compute the least-squares polynomial directly. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- if(iopt(1).lt.0) go to 120
-c acc denotes the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c numax and nvmax denote the number of knots needed for interpolation.
- numax = mu+5+iopt(2)+iopt(3)
- nvmax = mv+7
- nue = min0(numax,nuest)
- nve = min0(nvmax,nvest)
- if(s.gt.0.) go to 100
-c if s = 0, s(u,v) is an interpolating spline.
- nu = numax
- nv = nvmax
-c test whether the required storage space exceeds the available one.
- if(nu.gt.nuest .or. nv.gt.nvest) go to 420
-c find the position of the knots in the v-direction.
- do 10 l=1,mv
- tv(l+3) = v(l)
- 10 continue
- tv(mv+4) = ve
- l1 = mv-2
- l2 = mv+5
- do 20 i=1,3
- tv(i) = v(l1)-per
- tv(l2) = v(i+1)+per
- l1 = l1+1
- l2 = l2+1
- 20 continue
-c if not all the derivative values g(i,j) are given, we will first
-c estimate these values by computing a least-squares spline
- idd(1) = ider(1)
- if(idd(1).eq.0) idd(1) = 1
- if(idd(1).gt.0) dz(1) = z0
- idd(2) = ider(2)
- if(ider(1).lt.0) go to 30
- if(iopt(2).eq.0 .or. ider(2).ne.0) go to 70
-c we set up the knots in the u-direction for computing the least-squares
-c spline.
- 30 i1 = 3
- i2 = mu-2
- nu = 4
- do 40 i=1,mu
- if(i1.gt.i2) go to 50
- nu = nu+1
- tu(nu) = u(i1)
- i1 = i1+2
- 40 continue
- 50 do 60 i=1,4
- tu(i) = 0.
- nu = nu+1
- tu(nu) = r
- 60 continue
-c we compute the least-squares spline for estimating the derivatives.
- call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd,
- * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv,
- * wrk,lwrk)
- ifsu = 0
-c if all the derivatives at the origin are known, we compute the
-c interpolating spline.
-c we set up the knots in the u-direction, needed for interpolation.
- 70 nn = numax-8
- if(nn.eq.0) go to 95
- ju = 2-iopt(2)
- do 80 l=1,nn
- tu(l+4) = u(ju)
- ju = ju+1
- 80 continue
- nu = numax
- l = nu
- do 90 i=1,4
- tu(i) = 0.
- tu(l) = r
- l = l-1
- 90 continue
-c we compute the interpolating spline.
- 95 call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd,
- * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv,
- * wrk,lwrk)
- go to 430
-c if s>0 our initial choice of knots depends on the value of iopt(1).
- 100 ier = 0
- if(iopt(1).eq.0) go to 115
- step = -step
- if(fp0.le.s) go to 115
-c if iopt(1)=1 and fp0 > s we start computing the least-squares spline
-c according to the set of knots found at the last call of the routine.
-c we determine the number of grid coordinates u(i) inside each knot
-c interval (tu(l),tu(l+1)).
- l = 5
- j = 1
- nrdatu(1) = 0
- mu0 = 2-iopt(2)
- mu1 = mu-2+iopt(3)
- do 105 i=mu0,mu1
- nrdatu(j) = nrdatu(j)+1
- if(u(i).lt.tu(l)) go to 105
- nrdatu(j) = nrdatu(j)-1
- l = l+1
- j = j+1
- nrdatu(j) = 0
- 105 continue
-c we determine the number of grid coordinates v(i) inside each knot
-c interval (tv(l),tv(l+1)).
- l = 5
- j = 1
- nrdatv(1) = 0
- do 110 i=2,mv
- nrdatv(j) = nrdatv(j)+1
- if(v(i).lt.tv(l)) go to 110
- nrdatv(j) = nrdatv(j)-1
- l = l+1
- j = j+1
- nrdatv(j) = 0
- 110 continue
- idd(1) = ider(1)
- idd(2) = ider(2)
- go to 120
-c if iopt(1)=0 or iopt(1)=1 and s >= fp0,we start computing the least-
-c squares polynomial (which is a spline without interior knots).
- 115 ier = -2
- idd(1) = ider(1)
- idd(2) = 1
- nu = 8
- nv = 8
- nrdatu(1) = mu-3+iopt(2)+iopt(3)
- nrdatv(1) = mv-1
- lastdi = 0
- nplusu = 0
- nplusv = 0
- fp0 = 0.
- fpold = 0.
- reducu = 0.
- reducv = 0.
-c main loop for the different sets of knots.mpm=mu+mv is a save upper
-c bound for the number of trials.
- 120 mpm = mu+mv
- do 270 iter=1,mpm
-c find nrintu (nrintv) which is the number of knot intervals in the
-c u-direction (v-direction).
- nrintu = nu-7
- nrintv = nv-7
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(u,v).
- i = nu
- do 130 j=1,4
- tu(j) = 0.
- tu(i) = r
- i = i-1
- 130 continue
- l1 = 4
- l2 = l1
- l3 = nv-3
- l4 = l3
- tv(l2) = vb
- tv(l3) = ve
- do 140 j=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tv(l2) = tv(l4)-per
- tv(l3) = tv(l1)+per
- 140 continue
-c find an estimate of the range of possible values for the optimal
-c derivatives at the origin.
- ktu = nrdatu(1)+2-iopt(2)
- if(nrintu.eq.1) ktu = mu
- if(ktu.lt.mumin) ktu = mumin
- if(ktu.eq.lasttu) go to 150
- zmin = z0
- zmax = z0
- l = mv*ktu
- do 145 i=1,l
- if(z(i).lt.zmin) zmin = z(i)
- if(z(i).gt.zmax) zmax = z(i)
- 145 continue
- step = zmax-zmin
- lasttu = ktu
-c find the least-squares spline sinf(u,v).
- 150 call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd,
- * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv,
- * wrk,lwrk)
- if(step.lt.0.) step = -step
- if(ier.eq.(-2)) fp0 = fp
-c test whether the least-squares spline is an acceptable solution.
- if(iopt(1).lt.0) go to 440
- fpms = fp-s
- if(abs(fpms) .lt. acc) go to 440
-c if f(p=inf) < s, we accept the choice of knots.
- if(fpms.lt.0.) go to 300
-c if nu=numax and nv=nvmax, sinf(u,v) is an interpolating spline
- if(nu.eq.numax .and. nv.eq.nvmax) go to 430
-c increase the number of knots.
-c if nu=nue and nv=nve we cannot further increase the number of knots
-c because of the storage capacity limitation.
- if(nu.eq.nue .and. nv.eq.nve) go to 420
- if(ider(1).eq.0) fpintu(1) = fpintu(1)+(z0-c(1))**2
- ier = 0
-c adjust the parameter reducu or reducv according to the direction
-c in which the last added knots were located.
- if (lastdi.lt.0) go to 160
- if (lastdi.eq.0) go to 155
- go to 170
- 155 nplv = 3
- idd(2) = ider(2)
- fpold = fp
- go to 230
- 160 reducu = fpold-fp
- go to 175
- 170 reducv = fpold-fp
-c store the sum of squared residuals for the current set of knots.
- 175 fpold = fp
-c find nplu, the number of knots we should add in the u-direction.
- nplu = 1
- if(nu.eq.8) go to 180
- npl1 = nplusu*2
- rn = nplusu
- if(reducu.gt.acc) npl1 = rn*fpms/reducu
- nplu = min0(nplusu*2,max0(npl1,nplusu/2,1))
-c find nplv, the number of knots we should add in the v-direction.
- 180 nplv = 3
- if(nv.eq.8) go to 190
- npl1 = nplusv*2
- rn = nplusv
- if(reducv.gt.acc) npl1 = rn*fpms/reducv
- nplv = min0(nplusv*2,max0(npl1,nplusv/2,1))
-c test whether we are going to add knots in the u- or v-direction.
- 190 if (nplu.lt.nplv) go to 210
- if (nplu.eq.nplv) go to 200
- go to 230
- 200 if(lastdi.lt.0) go to 230
- 210 if(nu.eq.nue) go to 230
-c addition in the u-direction.
- lastdi = -1
- nplusu = nplu
- ifsu = 0
- istart = 0
- if(iopt(2).eq.0) istart = 1
- do 220 l=1,nplusu
-c add a new knot in the u-direction
- call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,istart)
-c test whether we cannot further increase the number of knots in the
-c u-direction.
- if(nu.eq.nue) go to 270
- 220 continue
- go to 270
- 230 if(nv.eq.nve) go to 210
-c addition in the v-direction.
- lastdi = 1
- nplusv = nplv
- ifsv = 0
- do 240 l=1,nplusv
-c add a new knot in the v-direction.
- call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1)
-c test whether we cannot further increase the number of knots in the
-c v-direction.
- if(nv.eq.nve) go to 270
- 240 continue
-c restart the computations with the new set of knots.
- 270 continue
-c test whether the least-squares polynomial is a solution of our
-c approximation problem.
- 300 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline sp(u,v) c
-c ***************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the b-spline coefficients of the smoothing spline sp(u,v). c
-c this smoothing spline depends on the parameter p in such a way that c
-c f(p) = sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c
-c is a continuous, strictly decreasing function of p. moreover the c
-c least-squares polynomial corresponds to p=0 and the least-squares c
-c spline to p=infinity. then iteratively we have to determine the c
-c positive value of p such that f(p)=s. the process which is proposed c
-c here makes use of rational interpolation. f(p) is approximated by a c
-c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c
-c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c
-c are used to calculate the new value of p such that r(p)=s. c
-c convergence is guaranteed by taking f1 > 0 and f3 < 0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = one
- dzz(1) = dz(1)
- dzz(2) = dz(2)
- dzz(3) = dz(3)
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p)=s.
- do 350 iter = 1,maxit
-c find the smoothing spline sp(u,v) and the corresponding sum f(p).
- call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dzz,iopt,idd,
- * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv,
- * wrk,lwrk)
-c test whether the approximation sp(u,v) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 320
- if((f2-f3).gt.acc) go to 310
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 350
- 310 if(f2.lt.0.) ich3 = 1
- 320 if(ich1.ne.0) go to 340
- if((f1-f2).gt.acc) go to 330
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 350
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 350
-c test whether the iteration process proceeds as theoretically
-c expected.
- 330 if(f2.gt.0.) ich1 = 1
- 340 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 350 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- fp = 0.
- 440 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fppola.f
===================================================================
--- branches/Interpolate1D/fitpack/fppola.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fppola.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,840 +0,0 @@
- subroutine fppola(iopt1,iopt2,iopt3,m,u,v,z,w,rad,s,nuest,nvest,
- * eta,tol,maxit,ib1,ib3,nc,ncc,intest,nrest,nu,tu,nv,tv,c,fp,sup,
- * fpint,coord,f,ff,row,cs,cosi,a,q,bu,bv,spu,spv,h,index,nummer,
- * wrk,lwrk,ier)
-c ..scalar arguments..
- integer iopt1,iopt2,iopt3,m,nuest,nvest,maxit,ib1,ib3,nc,ncc,
- * intest,nrest,nu,nv,lwrk,ier
- real*8 s,eta,tol,fp,sup
-c ..array arguments..
- integer index(nrest),nummer(m)
- real*8 u(m),v(m),z(m),w(m),tu(nuest),tv(nvest),c(nc),fpint(intest)
- *,
- * coord(intest),f(ncc),ff(nc),row(nvest),cs(nvest),cosi(5,nvest),
- * a(ncc,ib1),q(ncc,ib3),bu(nuest,5),bv(nvest,5),spu(m,4),spv(m,4),
- * h(ib3),wrk(lwrk)
-c ..user supplied function..
- real*8 rad
-c ..local scalars..
- real*8 acc,arg,co,c1,c2,c3,c4,dmax,eps,fac,fac1,fac2,fpmax,fpms,
- * f1,f2,f3,hui,huj,p,pi,pinv,piv,pi2,p1,p2,p3,r,ratio,si,sigma,
- * sq,store,uu,u2,u3,wi,zi,rn,one,two,three,con1,con4,con9,half,ten
- integer i,iband,iband3,iband4,ich1,ich3,ii,il,in,ipar,ipar1,irot,
- * iter,i1,i2,i3,j,jl,jrot,j1,j2,k,l,la,lf,lh,ll,lu,lv,lwest,l1,l2,
- * l3,l4,ncof,ncoff,nvv,nv4,nreg,nrint,nrr,nr1,nuu,nu4,num,num1,
- * numin,nvmin,rank,iband1
-c ..local arrays..
- real*8 hu(4),hv(4)
-c ..function references..
- real*8 abs,atan,cos,fprati,sin,sqrt
- integer min0
-c ..subroutine references..
-c fporde,fpbspl,fpback,fpgivs,fprota,fprank,fpdisc,fprppo
-c ..
-c set constants
- one = 1
- two = 2
- three = 3
- ten = 10
- half = 0.5e0
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- pi = atan(one)*4
- pi2 = pi+pi
- ipar = iopt2*(iopt2+3)/2
- ipar1 = ipar+1
- eps = sqrt(eta)
- if(iopt1.lt.0) go to 90
- numin = 9
- nvmin = 9+iopt2*(iopt2+1)
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
- if(iopt1.eq.0) go to 10
- if(s.lt.sup) then
- if (nv.lt.nvmin) go to 70
- go to 90
- endif
-c if iopt1 = 0 we begin by computing the weighted least-squares
-c polymomial of the form
-c s(u,v) = f(1)*(1-u**3)+f(2)*u**3+f(3)*(u**2-u**3)+f(4)*(u-u**3)
-c where f(4) = 0 if iopt2> 0 , f(3) = 0 if iopt2 > 1 and
-c f(2) = 0 if iopt3> 0.
-c the corresponding weighted sum of squared residuals gives the upper
-c bound sup for the smoothing factor s.
- 10 sup = 0.
- do 20 i=1,4
- f(i) = 0.
- do 20 j=1,4
- a(i,j) = 0.
- 20 continue
- do 50 i=1,m
- wi = w(i)
- zi = z(i)*wi
- uu = u(i)
- u2 = uu*uu
- u3 = uu*u2
- h(1) = (one-u3)*wi
- h(2) = u3*wi
- h(3) = u2*(one-uu)*wi
- h(4) = uu*(one-u2)*wi
- if(iopt3.ne.0) h(2) = 0.
- if(iopt2.gt.1) h(3) = 0.
- if(iopt2.gt.0) h(4) = 0.
- do 40 j=1,4
- piv = h(j)
- if(piv.eq.0.) go to 40
- call fpgivs(piv,a(j,1),co,si)
- call fprota(co,si,zi,f(j))
- if(j.eq.4) go to 40
- j1 = j+1
- j2 = 1
- do 30 l=j1,4
- j2 = j2+1
- call fprota(co,si,h(l),a(j,j2))
- 30 continue
- 40 continue
- sup = sup+zi*zi
- 50 continue
- if(a(4,1).ne.0.) f(4) = f(4)/a(4,1)
- if(a(3,1).ne.0.) f(3) = (f(3)-a(3,2)*f(4))/a(3,1)
- if(a(2,1).ne.0.) f(2) = (f(2)-a(2,2)*f(3)-a(2,3)*f(4))/a(2,1)
- if(a(1,1).ne.0.)
- * f(1) = (f(1)-a(1,2)*f(2)-a(1,3)*f(3)-a(1,4)*f(4))/a(1,1)
-c find the b-spline representation of this least-squares polynomial
- c1 = f(1)
- c4 = f(2)
- c2 = f(4)/three+c1
- c3 = (f(3)+two*f(4))/three+c1
- nu = 8
- nv = 8
- do 60 i=1,4
- c(i) = c1
- c(i+4) = c2
- c(i+8) = c3
- c(i+12) = c4
- tu(i) = 0.
- tu(i+4) = one
- rn = 2*i-9
- tv(i) = rn*pi
- rn = 2*i-1
- tv(i+4) = rn*pi
- 60 continue
- fp = sup
-c test whether the least-squares polynomial is an acceptable solution
- fpms = sup-s
- if(fpms.lt.acc) go to 960
-c test whether we cannot further increase the number of knots.
- 70 if(nuest.lt.numin .or. nvest.lt.nvmin) go to 950
-c find the initial set of interior knots of the spline in case iopt1=0.
- nu = numin
- nv = nvmin
- tu(5) = half
- nvv = nv-8
- rn = nvv+1
- fac = pi2/rn
- do 80 i=1,nvv
- rn = i
- tv(i+4) = rn*fac-pi
- 80 continue
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1 : computation of least-squares bicubic splines. c
-c ****************************************************** c
-c if iopt1<0 we compute the least-squares bicubic spline according c
-c to the given set of knots. c
-c if iopt1>=0 we compute least-squares bicubic splines with in- c
-c creasing numbers of knots until the corresponding sum f(p=inf)<=s. c
-c the initial set of knots then depends on the value of iopt1 c
-c if iopt1=0 we start with one interior knot in the u-direction c
-c (0.5) and 1+iopt2*(iopt2+1) in the v-direction. c
-c if iopt1>0 we start with the set of knots found at the last c
-c call of the routine. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c main loop for the different sets of knots. m is a save upper bound
-c for the number of trials.
- 90 do 570 iter=1,m
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(u,v).
- l1 = 4
- l2 = l1
- l3 = nv-3
- l4 = l3
- tv(l2) = -pi
- tv(l3) = pi
- do 120 i=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tv(l2) = tv(l4)-pi2
- tv(l3) = tv(l1)+pi2
- 120 continue
- l = nu
- do 130 i=1,4
- tu(i) = 0.
- tu(l) = one
- l = l-1
- 130 continue
-c find nrint, the total number of knot intervals and nreg, the number
-c of panels in which the approximation domain is subdivided by the
-c intersection of knots.
- nuu = nu-7
- nvv = nv-7
- nrr = nvv/2
- nr1 = nrr+1
- nrint = nuu+nvv
- nreg = nuu*nvv
-c arrange the data points according to the panel they belong to.
- call fporde(u,v,m,3,3,tu,nu,tv,nv,nummer,index,nreg)
- if(iopt2.eq.0) go to 195
-c find the b-spline coefficients cosi of the cubic spline
-c approximations for cr(v)=rad(v)*cos(v) and sr(v) = rad(v)*sin(v)
-c if iopt2=1, and additionally also for cr(v)**2,sr(v)**2 and
-c 2*cr(v)*sr(v) if iopt2=2
- do 140 i=1,nvv
- do 135 j=1,ipar
- cosi(j,i) = 0.
- 135 continue
- do 140 j=1,nvv
- a(i,j) = 0.
- 140 continue
-c the coefficients cosi are obtained from interpolation conditions
-c at the knots tv(i),i=4,5,...nv-4.
- do 175 i=1,nvv
- l2 = i+3
- arg = tv(l2)
- call fpbspl(tv,nv,3,arg,l2,hv)
- do 145 j=1,nvv
- row(j) = 0.
- 145 continue
- ll = i
- do 150 j=1,3
- if(ll.gt.nvv) ll= 1
- row(ll) = row(ll)+hv(j)
- ll = ll+1
- 150 continue
- co = cos(arg)
- si = sin(arg)
- r = rad(arg)
- cs(1) = co*r
- cs(2) = si*r
- if(iopt2.eq.1) go to 155
- cs(3) = cs(1)*cs(1)
- cs(4) = cs(2)*cs(2)
- cs(5) = cs(1)*cs(2)
- 155 do 170 j=1,nvv
- piv = row(j)
- if(piv.eq.0.) go to 170
- call fpgivs(piv,a(j,1),co,si)
- do 160 l=1,ipar
- call fprota(co,si,cs(l),cosi(l,j))
- 160 continue
- if(j.eq.nvv) go to 175
- j1 = j+1
- j2 = 1
- do 165 l=j1,nvv
- j2 = j2+1
- call fprota(co,si,row(l),a(j,j2))
- 165 continue
- 170 continue
- 175 continue
- do 190 l=1,ipar
- do 180 j=1,nvv
- cs(j) = cosi(l,j)
- 180 continue
- call fpback(a,cs,nvv,nvv,cs,ncc)
- do 185 j=1,nvv
- cosi(l,j) = cs(j)
- 185 continue
- 190 continue
-c find ncof, the dimension of the spline and ncoff, the number
-c of coefficients in the standard b-spline representation.
- 195 nu4 = nu-4
- nv4 = nv-4
- ncoff = nu4*nv4
- ncof = ipar1+nvv*(nu4-1-iopt2-iopt3)
-c find the bandwidth of the observation matrix a.
- iband = 4*nvv
- if(nuu-iopt2-iopt3.le.1) iband = ncof
- iband1 = iband-1
-c initialize the observation matrix a.
- do 200 i=1,ncof
- f(i) = 0.
- do 200 j=1,iband
- a(i,j) = 0.
- 200 continue
-c initialize the sum of squared residuals.
- fp = 0.
- ratio = one+tu(6)/tu(5)
-c fetch the data points in the new order. main loop for the
-c different panels.
- do 380 num=1,nreg
-c fix certain constants for the current panel; jrot records the column
-c number of the first non-zero element in a row of the observation
-c matrix according to a data point of the panel.
- num1 = num-1
- lu = num1/nvv
- l1 = lu+4
- lv = num1-lu*nvv+1
- l2 = lv+3
- jrot = 0
- if(lu.gt.iopt2) jrot = ipar1+(lu-iopt2-1)*nvv
- lu = lu+1
-c test whether there are still data points in the current panel.
- in = index(num)
- 210 if(in.eq.0) go to 380
-c fetch a new data point.
- wi = w(in)
- zi = z(in)*wi
-c evaluate for the u-direction, the 4 non-zero b-splines at u(in)
- call fpbspl(tu,nu,3,u(in),l1,hu)
-c evaluate for the v-direction, the 4 non-zero b-splines at v(in)
- call fpbspl(tv,nv,3,v(in),l2,hv)
-c store the value of these b-splines in spu and spv resp.
- do 220 i=1,4
- spu(in,i) = hu(i)
- spv(in,i) = hv(i)
- 220 continue
-c initialize the new row of observation matrix.
- do 240 i=1,iband
- h(i) = 0.
- 240 continue
-c calculate the non-zero elements of the new row by making the cross
-c products of the non-zero b-splines in u- and v-direction and
-c by taking into account the conditions of the splines.
- do 250 i=1,nvv
- row(i) = 0.
- 250 continue
-c take into account the periodicity condition of the bicubic splines.
- ll = lv
- do 260 i=1,4
- if(ll.gt.nvv) ll=1
- row(ll) = row(ll)+hv(i)
- ll = ll+1
- 260 continue
-c take into account the other conditions of the splines.
- if(iopt2.eq.0 .or. lu.gt.iopt2+1) go to 280
- do 270 l=1,ipar
- cs(l) = 0.
- do 270 i=1,nvv
- cs(l) = cs(l)+row(i)*cosi(l,i)
- 270 continue
-c fill in the non-zero elements of the new row.
- 280 j1 = 0
- do 330 j =1,4
- jlu = j+lu
- huj = hu(j)
- if(jlu.gt.iopt2+2) go to 320
- go to (290,290,300,310),jlu
- 290 h(1) = huj
- j1 = 1
- go to 330
- 300 h(1) = h(1)+huj
- h(2) = huj*cs(1)
- h(3) = huj*cs(2)
- j1 = 3
- go to 330
- 310 h(1) = h(1)+huj
- h(2) = h(2)+huj*ratio*cs(1)
- h(3) = h(3)+huj*ratio*cs(2)
- h(4) = huj*cs(3)
- h(5) = huj*cs(4)
- h(6) = huj*cs(5)
- j1 = 6
- go to 330
- 320 if(jlu.gt.nu4 .and. iopt3.ne.0) go to 330
- do 325 i=1,nvv
- j1 = j1+1
- h(j1) = row(i)*huj
- 325 continue
- 330 continue
- do 335 i=1,iband
- h(i) = h(i)*wi
- 335 continue
-c rotate the row into triangle by givens transformations.
- irot = jrot
- do 350 i=1,iband
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 350
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(irot,1),co,si)
-c apply that transformation to the right hand side.
- call fprota(co,si,zi,f(irot))
- if(i.eq.iband) go to 360
-c apply that transformation to the left hand side.
- i2 = 1
- i3 = i+1
- do 340 j=i3,iband
- i2 = i2+1
- call fprota(co,si,h(j),a(irot,i2))
- 340 continue
- 350 continue
-c add the contribution of the row to the sum of squares of residual
-c right hand sides.
- 360 fp = fp+zi**2
-c find the number of the next data point in the panel.
- 370 in = nummer(in)
- go to 210
- 380 continue
-c find dmax, the maximum value for the diagonal elements in the reduced
-c triangle.
- dmax = 0.
- do 390 i=1,ncof
- if(a(i,1).le.dmax) go to 390
- dmax = a(i,1)
- 390 continue
-c check whether the observation matrix is rank deficient.
- sigma = eps*dmax
- do 400 i=1,ncof
- if(a(i,1).le.sigma) go to 410
- 400 continue
-c backward substitution in case of full rank.
- call fpback(a,f,ncof,iband,c,ncc)
- rank = ncof
- do 405 i=1,ncof
- q(i,1) = a(i,1)/dmax
- 405 continue
- go to 430
-c in case of rank deficiency, find the minimum norm solution.
- 410 lwest = ncof*iband+ncof+iband
- if(lwrk.lt.lwest) go to 925
- lf = 1
- lh = lf+ncof
- la = lh+iband
- do 420 i=1,ncof
- ff(i) = f(i)
- do 420 j=1,iband
- q(i,j) = a(i,j)
- 420 continue
- call fprank(q,ff,ncof,iband,ncc,sigma,c,sq,rank,wrk(la),
- * wrk(lf),wrk(lh))
- do 425 i=1,ncof
- q(i,1) = q(i,1)/dmax
- 425 continue
-c add to the sum of squared residuals, the contribution of reducing
-c the rank.
- fp = fp+sq
-c find the coefficients in the standard b-spline representation of
-c the spline.
- 430 call fprppo(nu,nv,iopt2,iopt3,cosi,ratio,c,ff,ncoff)
-c test whether the least-squares spline is an acceptable solution.
- if(iopt1.lt.0) then
- if (fp.le.0) go to 970
- go to 980
- endif
- fpms = fp-s
- if(abs(fpms).le.acc) then
- if (fp.le.0) go to 970
- go to 980
- endif
-c if f(p=inf) < s, accept the choice of knots.
- if(fpms.lt.0.) go to 580
-c test whether we cannot further increase the number of knots
- if(m.lt.ncof) go to 935
-c search where to add a new knot.
-c find for each interval the sum of squared residuals fpint for the
-c data points having the coordinate belonging to that knot interval.
-c calculate also coord which is the same sum, weighted by the position
-c of the data points considered.
- 440 do 450 i=1,nrint
- fpint(i) = 0.
- coord(i) = 0.
- 450 continue
- do 490 num=1,nreg
- num1 = num-1
- lu = num1/nvv
- l1 = lu+1
- lv = num1-lu*nvv
- l2 = lv+1+nuu
- jrot = lu*nv4+lv
- in = index(num)
- 460 if(in.eq.0) go to 490
- store = 0.
- i1 = jrot
- do 480 i=1,4
- hui = spu(in,i)
- j1 = i1
- do 470 j=1,4
- j1 = j1+1
- store = store+hui*spv(in,j)*c(j1)
- 470 continue
- i1 = i1+nv4
- 480 continue
- store = (w(in)*(z(in)-store))**2
- fpint(l1) = fpint(l1)+store
- coord(l1) = coord(l1)+store*u(in)
- fpint(l2) = fpint(l2)+store
- coord(l2) = coord(l2)+store*v(in)
- in = nummer(in)
- go to 460
- 490 continue
-c bring together the information concerning knot panels which are
-c symmetric with respect to the origin.
- do 495 i=1,nrr
- l1 = nuu+i
- l2 = l1+nrr
- fpint(l1) = fpint(l1)+fpint(l2)
- coord(l1) = coord(l1)+coord(l2)-pi*fpint(l2)
- 495 continue
-c find the interval for which fpint is maximal on the condition that
-c there still can be added a knot.
- l1 = 1
- l2 = nuu+nrr
- if(nuest.lt.nu+1) l1=nuu+1
- if(nvest.lt.nv+2) l2=nuu
-c test whether we cannot further increase the number of knots.
- if(l1.gt.l2) go to 950
- 500 fpmax = 0.
- l = 0
- do 510 i=l1,l2
- if(fpmax.ge.fpint(i)) go to 510
- l = i
- fpmax = fpint(i)
- 510 continue
- if(l.eq.0) go to 930
-c calculate the position of the new knot.
- arg = coord(l)/fpint(l)
-c test in what direction the new knot is going to be added.
- if(l.gt.nuu) go to 530
-c addition in the u-direction
- l4 = l+4
- fpint(l) = 0.
- fac1 = tu(l4)-arg
- fac2 = arg-tu(l4-1)
- if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500
- j = nu
- do 520 i=l4,nu
- tu(j+1) = tu(j)
- j = j-1
- 520 continue
- tu(l4) = arg
- nu = nu+1
- go to 570
-c addition in the v-direction
- 530 l4 = l+4-nuu
- fpint(l) = 0.
- fac1 = tv(l4)-arg
- fac2 = arg-tv(l4-1)
- if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500
- ll = nrr+4
- j = ll
- do 550 i=l4,ll
- tv(j+1) = tv(j)
- j = j-1
- 550 continue
- tv(l4) = arg
- nv = nv+2
- nrr = nrr+1
- do 560 i=5,ll
- j = i+nrr
- tv(j) = tv(i)+pi
- 560 continue
-c restart the computations with the new set of knots.
- 570 continue
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing bicubic spline. c
-c ****************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the coefficients of the smoothing spline sp(u,v). c
-c the observation matrix a is extended by the rows of a matrix, expres-c
-c sing that sp(u,v) must be a constant function in the variable c
-c v and a cubic polynomial in the variable u. the corresponding c
-c weights of these additional rows are set to 1/(p). iteratively c
-c we than have to determine the value of p such that f(p) = sum((w(i)* c
-c (z(i)-sp(u(i),v(i))))**2) be = s. c
-c we already know that the least-squares polynomial corresponds to p=0,c
-c and that the least-squares bicubic spline corresponds to p=infin. c
-c the iteration process makes use of rational interpolation. since f(p)c
-c is a convex and strictly decreasing function of p, it can be approx- c
-c imated by a rational function of the form r(p) = (u*p+v)/(p+w). c
-c three values of p (p1,p2,p3) with corresponding values of f(p) (f1= c
-c f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the new value c
-c of p such that r(p)=s. convergence is guaranteed by taking f1>0,f3<0.c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jumps of the 3-th order derivative of
-c the b-splines at the knots tu(l),l=5,...,nu-4.
- 580 call fpdisc(tu,nu,5,bu,nuest)
-c evaluate the discontinuity jumps of the 3-th order derivative of
-c the b-splines at the knots tv(l),l=5,...,nv-4.
- call fpdisc(tv,nv,5,bv,nvest)
-c initial value for p.
- p1 = 0.
- f1 = sup-s
- p3 = -one
- f3 = fpms
- p = 0.
- do 590 i=1,ncof
- p = p+a(i,1)
- 590 continue
- rn = ncof
- p = rn/p
-c find the bandwidth of the extended observation matrix.
- iband4 = iband+ipar1
- if(iband4.gt.ncof) iband4 = ncof
- iband3 = iband4 -1
- ich1 = 0
- ich3 = 0
- nuu = nu4-iopt3-1
-c iteration process to find the root of f(p)=s.
- do 920 iter=1,maxit
- pinv = one/p
-c store the triangularized observation matrix into q.
- do 630 i=1,ncof
- ff(i) = f(i)
- do 620 j=1,iband4
- q(i,j) = 0.
- 620 continue
- do 630 j=1,iband
- q(i,j) = a(i,j)
- 630 continue
-c extend the observation matrix with the rows of a matrix, expressing
-c that for u=constant sp(u,v) must be a constant function.
- do 720 i=5,nv4
- ii = i-4
- do 635 l=1,nvv
- row(l) = 0.
- 635 continue
- ll = ii
- do 640 l=1,5
- if(ll.gt.nvv) ll=1
- row(ll) = row(ll)+bv(ii,l)
- ll = ll+1
- 640 continue
- do 720 j=1,nuu
-c initialize the new row.
- do 645 l=1,iband
- h(l) = 0.
- 645 continue
-c fill in the non-zero elements of the row. jrot records the column
-c number of the first non-zero element in the row.
- if(j.gt.iopt2) go to 665
- if(j.eq.2) go to 655
- do 650 k=1,2
- cs(k) = 0.
- do 650 l=1,nvv
- cs(k) = cs(k)+cosi(k,l)*row(l)
- 650 continue
- h(1) = cs(1)
- h(2) = cs(2)
- jrot = 2
- go to 675
- 655 do 660 k=3,5
- cs(k) = 0.
- do 660 l=1,nvv
- cs(k) = cs(k)+cosi(k,l)*row(l)
- 660 continue
- h(1) = cs(1)*ratio
- h(2) = cs(2)*ratio
- h(3) = cs(3)
- h(4) = cs(4)
- h(5) = cs(5)
- jrot = 2
- go to 675
- 665 do 670 l=1,nvv
- h(l) = row(l)
- 670 continue
- jrot = ipar1+1+(j-iopt2-1)*nvv
- 675 do 677 l=1,iband
- h(l) = h(l)*pinv
- 677 continue
- zi = 0.
-c rotate the new row into triangle by givens transformations.
- do 710 irot=jrot,ncof
- piv = h(1)
- i2 = min0(iband1,ncof-irot)
- if(piv.eq.0.) then
- if (i2.le.0) go to 720
- go to 690
- endif
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,q(irot,1),co,si)
-c apply that givens transformation to the right hand side.
- call fprota(co,si,zi,ff(irot))
- if(i2.eq.0) go to 720
-c apply that givens transformation to the left hand side.
- do 680 l=1,i2
- l1 = l+1
- call fprota(co,si,h(l1),q(irot,l1))
- 680 continue
- 690 do 700 l=1,i2
- h(l) = h(l+1)
- 700 continue
- h(i2+1) = 0.
- 710 continue
- 720 continue
-c extend the observation matrix with the rows of a matrix expressing
-c that for v=constant. sp(u,v) must be a cubic polynomial.
- do 810 i=5,nu4
- ii = i-4
- do 810 j=1,nvv
-c initialize the new row
- do 730 l=1,iband4
- h(l) = 0.
- 730 continue
-c fill in the non-zero elements of the row. jrot records the column
-c number of the first non-zero element in the row.
- j1 = 1
- do 760 l=1,5
- il = ii+l-1
- if(il.eq.nu4 .and. iopt3.ne.0) go to 760
- if(il.gt.iopt2+1) go to 750
- go to (735,740,745),il
- 735 h(1) = bu(ii,l)
- j1 = j+1
- go to 760
- 740 h(1) = h(1)+bu(ii,l)
- h(2) = bu(ii,l)*cosi(1,j)
- h(3) = bu(ii,l)*cosi(2,j)
- j1 = j+3
- go to 760
- 745 h(1) = h(1)+bu(ii,l)
- h(2) = bu(ii,l)*cosi(1,j)*ratio
- h(3) = bu(ii,l)*cosi(2,j)*ratio
- h(4) = bu(ii,l)*cosi(3,j)
- h(5) = bu(ii,l)*cosi(4,j)
- h(6) = bu(ii,l)*cosi(5,j)
- j1 = j+6
- go to 760
- 750 h(j1) = bu(ii,l)
- j1 = j1+nvv
- 760 continue
- do 765 l=1,iband4
- h(l) = h(l)*pinv
- 765 continue
- zi = 0.
- jrot = 1
- if(ii.gt.iopt2+1) jrot = ipar1+(ii-iopt2-2)*nvv+j
-c rotate the new row into triangle by givens transformations.
- do 800 irot=jrot,ncof
- piv = h(1)
- i2 = min0(iband3,ncof-irot)
- if(piv.eq.0.) then
- if (i2.le.0) go to 810
- go to 780
- endif
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,q(irot,1),co,si)
-c apply that givens transformation to the right hand side.
- call fprota(co,si,zi,ff(irot))
- if(i2.eq.0) go to 810
-c apply that givens transformation to the left hand side.
- do 770 l=1,i2
- l1 = l+1
- call fprota(co,si,h(l1),q(irot,l1))
- 770 continue
- 780 do 790 l=1,i2
- h(l) = h(l+1)
- 790 continue
- h(i2+1) = 0.
- 800 continue
- 810 continue
-c find dmax, the maximum value for the diagonal elements in the
-c reduced triangle.
- dmax = 0.
- do 820 i=1,ncof
- if(q(i,1).le.dmax) go to 820
- dmax = q(i,1)
- 820 continue
-c check whether the matrix is rank deficient.
- sigma = eps*dmax
- do 830 i=1,ncof
- if(q(i,1).le.sigma) go to 840
- 830 continue
-c backward substitution in case of full rank.
- call fpback(q,ff,ncof,iband4,c,ncc)
- rank = ncof
- go to 845
-c in case of rank deficiency, find the minimum norm solution.
- 840 lwest = ncof*iband4+ncof+iband4
- if(lwrk.lt.lwest) go to 925
- lf = 1
- lh = lf+ncof
- la = lh+iband4
- call fprank(q,ff,ncof,iband4,ncc,sigma,c,sq,rank,wrk(la),
- * wrk(lf),wrk(lh))
- 845 do 850 i=1,ncof
- q(i,1) = q(i,1)/dmax
- 850 continue
-c find the coefficients in the standard b-spline representation of
-c the polar spline.
- call fprppo(nu,nv,iopt2,iopt3,cosi,ratio,c,ff,ncoff)
-c compute f(p).
- fp = 0.
- do 890 num = 1,nreg
- num1 = num-1
- lu = num1/nvv
- lv = num1-lu*nvv
- jrot = lu*nv4+lv
- in = index(num)
- 860 if(in.eq.0) go to 890
- store = 0.
- i1 = jrot
- do 880 i=1,4
- hui = spu(in,i)
- j1 = i1
- do 870 j=1,4
- j1 = j1+1
- store = store+hui*spv(in,j)*c(j1)
- 870 continue
- i1 = i1+nv4
- 880 continue
- fp = fp+(w(in)*(z(in)-store))**2
- in = nummer(in)
- go to 860
- 890 continue
-c test whether the approximation sp(u,v) is an acceptable solution
- fpms = fp-s
- if(abs(fpms).le.acc) go to 980
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 940
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 900
- if((f2-f3).gt.acc) go to 895
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 920
- 895 if(f2.lt.0.) ich3 = 1
- 900 if(ich1.ne.0) go to 910
- if((f1-f2).gt.acc) go to 905
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 920
- if(p.ge.p3) p = p2*con1 +p3*con9
- go to 920
- 905 if(f2.gt.0.) ich1 = 1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 910 if(f2.ge.f1 .or. f2.le.f3) go to 945
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 920 continue
-c error codes and messages.
- 925 ier = lwest
- go to 990
- 930 ier = 5
- go to 990
- 935 ier = 4
- go to 990
- 940 ier = 3
- go to 990
- 945 ier = 2
- go to 990
- 950 ier = 1
- go to 990
- 960 ier = -2
- go to 990
- 970 ier = -1
- fp = 0.
- 980 if(ncof.ne.rank) ier = -rank
- 990 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fprank.f
===================================================================
--- branches/Interpolate1D/fitpack/fprank.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fprank.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,236 +0,0 @@
- subroutine fprank(a,f,n,m,na,tol,c,sq,rank,aa,ff,h)
-c subroutine fprank finds the minimum norm solution of a least-
-c squares problem in case of rank deficiency.
-c
-c input parameters:
-c a : array, which contains the non-zero elements of the observation
-c matrix after triangularization by givens transformations.
-c f : array, which contains the transformed right hand side.
-c n : integer,wich contains the dimension of a.
-c m : integer, which denotes the bandwidth of a.
-c tol : real value, giving a threshold to determine the rank of a.
-c
-c output parameters:
-c c : array, which contains the minimum norm solution.
-c sq : real value, giving the contribution of reducing the rank
-c to the sum of squared residuals.
-c rank : integer, which contains the rank of matrix a.
-c
-c ..scalar arguments..
- integer n,m,na,rank
- real*8 tol,sq
-c ..array arguments..
- real*8 a(na,m),f(n),c(n),aa(n,m),ff(n),h(m)
-c ..local scalars..
- integer i,ii,ij,i1,i2,j,jj,j1,j2,j3,k,kk,m1,nl
- real*8 cos,fac,piv,sin,yi
- double precision store,stor1,stor2,stor3
-c ..function references..
- integer min0
-c ..subroutine references..
-c fpgivs,fprota
-c ..
- m1 = m-1
-c the rank deficiency nl is considered to be the number of sufficient
-c small diagonal elements of a.
- nl = 0
- sq = 0.
- do 90 i=1,n
- if(a(i,1).gt.tol) go to 90
-c if a sufficient small diagonal element is found, we put it to
-c zero. the remainder of the row corresponding to that zero diagonal
-c element is then rotated into triangle by givens rotations .
-c the rank deficiency is increased by one.
- nl = nl+1
- if(i.eq.n) go to 90
- yi = f(i)
- do 10 j=1,m1
- h(j) = a(i,j+1)
- 10 continue
- h(m) = 0.
- i1 = i+1
- do 60 ii=i1,n
- i2 = min0(n-ii,m1)
- piv = h(1)
- if(piv.eq.0.) go to 30
- call fpgivs(piv,a(ii,1),cos,sin)
- call fprota(cos,sin,yi,f(ii))
- if(i2.eq.0) go to 70
- do 20 j=1,i2
- j1 = j+1
- call fprota(cos,sin,h(j1),a(ii,j1))
- h(j) = h(j1)
- 20 continue
- go to 50
- 30 if(i2.eq.0) go to 70
- do 40 j=1,i2
- h(j) = h(j+1)
- 40 continue
- 50 h(i2+1) = 0.
- 60 continue
-c add to the sum of squared residuals the contribution of deleting
-c the row with small diagonal element.
- 70 sq = sq+yi**2
- 90 continue
-c rank denotes the rank of a.
- rank = n-nl
-c let b denote the (rank*n) upper trapezoidal matrix which can be
-c obtained from the (n*n) upper triangular matrix a by deleting
-c the rows and interchanging the columns corresponding to a zero
-c diagonal element. if this matrix is factorized using givens
-c transformations as b = (r) (u) where
-c r is a (rank*rank) upper triangular matrix,
-c u is a (rank*n) orthonormal matrix
-c then the minimal least-squares solution c is given by c = b' v,
-c where v is the solution of the system (r) (r)' v = g and
-c g denotes the vector obtained from the old right hand side f, by
-c removing the elements corresponding to a zero diagonal element of a.
-c initialization.
- do 100 i=1,rank
- do 100 j=1,m
- aa(i,j) = 0.
- 100 continue
-c form in aa the upper triangular matrix obtained from a by
-c removing rows and columns with zero diagonal elements. form in ff
-c the new right hand side by removing the elements of the old right
-c hand side corresponding to a deleted row.
- ii = 0
- do 120 i=1,n
- if(a(i,1).le.tol) go to 120
- ii = ii+1
- ff(ii) = f(i)
- aa(ii,1) = a(i,1)
- jj = ii
- kk = 1
- j = i
- j1 = min0(j-1,m1)
- if(j1.eq.0) go to 120
- do 110 k=1,j1
- j = j-1
- if(a(j,1).le.tol) go to 110
- kk = kk+1
- jj = jj-1
- aa(jj,kk) = a(j,k+1)
- 110 continue
- 120 continue
-c form successively in h the columns of a with a zero diagonal element.
- ii = 0
- do 200 i=1,n
- ii = ii+1
- if(a(i,1).gt.tol) go to 200
- ii = ii-1
- if(ii.eq.0) go to 200
- jj = 1
- j = i
- j1 = min0(j-1,m1)
- do 130 k=1,j1
- j = j-1
- if(a(j,1).le.tol) go to 130
- h(jj) = a(j,k+1)
- jj = jj+1
- 130 continue
- do 140 kk=jj,m
- h(kk) = 0.
- 140 continue
-c rotate this column into aa by givens transformations.
- jj = ii
- do 190 i1=1,ii
- j1 = min0(jj-1,m1)
- piv = h(1)
- if(piv.ne.0.) go to 160
- if(j1.eq.0) go to 200
- do 150 j2=1,j1
- j3 = j2+1
- h(j2) = h(j3)
- 150 continue
- go to 180
- 160 call fpgivs(piv,aa(jj,1),cos,sin)
- if(j1.eq.0) go to 200
- kk = jj
- do 170 j2=1,j1
- j3 = j2+1
- kk = kk-1
- call fprota(cos,sin,h(j3),aa(kk,j3))
- h(j2) = h(j3)
- 170 continue
- 180 jj = jj-1
- h(j3) = 0.
- 190 continue
- 200 continue
-c solve the system (aa) (f1) = ff
- ff(rank) = ff(rank)/aa(rank,1)
- i = rank-1
- if(i.eq.0) go to 230
- do 220 j=2,rank
- store = ff(i)
- i1 = min0(j-1,m1)
- k = i
- do 210 ii=1,i1
- k = k+1
- stor1 = ff(k)
- stor2 = aa(i,ii+1)
- store = store-stor1*stor2
- 210 continue
- stor1 = aa(i,1)
- ff(i) = store/stor1
- i = i-1
- 220 continue
-c solve the system (aa)' (f2) = f1
- 230 ff(1) = ff(1)/aa(1,1)
- if(rank.eq.1) go to 260
- do 250 j=2,rank
- store = ff(j)
- i1 = min0(j-1,m1)
- k = j
- do 240 ii=1,i1
- k = k-1
- stor1 = ff(k)
- stor2 = aa(k,ii+1)
- store = store-stor1*stor2
- 240 continue
- stor1 = aa(j,1)
- ff(j) = store/stor1
- 250 continue
-c premultiply f2 by the transpoze of a.
- 260 k = 0
- do 280 i=1,n
- store = 0.
- if(a(i,1).gt.tol) k = k+1
- j1 = min0(i,m)
- kk = k
- ij = i+1
- do 270 j=1,j1
- ij = ij-1
- if(a(ij,1).le.tol) go to 270
- stor1 = a(ij,j)
- stor2 = ff(kk)
- store = store+stor1*stor2
- kk = kk-1
- 270 continue
- c(i) = store
- 280 continue
-c add to the sum of squared residuals the contribution of putting
-c to zero the small diagonal elements of matrix (a).
- stor3 = 0.
- do 310 i=1,n
- if(a(i,1).gt.tol) go to 310
- store = f(i)
- i1 = min0(n-i,m1)
- if(i1.eq.0) go to 300
- do 290 j=1,i1
- ij = i+j
- stor1 = c(ij)
- stor2 = a(i,j+1)
- store = store-stor1*stor2
- 290 continue
- 300 fac = a(i,1)*c(i)
- stor1 = a(i,1)
- stor2 = c(i)
- stor1 = stor1*stor2
- stor3 = stor3+stor1*(stor1-store-store)
- 310 continue
- fac = stor3
- sq = sq+fac
- return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fprati.f
===================================================================
--- branches/Interpolate1D/fitpack/fprati.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fprati.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,29 +0,0 @@
- real*8 function fprati(p1,f1,p2,f2,p3,f3)
-c given three points (p1,f1),(p2,f2) and (p3,f3), function fprati
-c gives the value of p such that the rational interpolating function
-c of the form r(p) = (u*p+v)/(p+w) equals zero at p.
-c ..
-c ..scalar arguments..
- real*8 p1,f1,p2,f2,p3,f3
-c ..local scalars..
- real*8 h1,h2,h3,p
-c ..
- if(p3.gt.0.) go to 10
-c value of p in case p3 = infinity.
- p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3)
- go to 20
-c value of p in case p3 ^= infinity.
- 10 h1 = f1*(f2-f3)
- h2 = f2*(f3-f1)
- h3 = f3*(f1-f2)
- p = -(p1*p2*h3+p2*p3*h1+p3*p1*h2)/(p1*h1+p2*h2+p3*h3)
-c adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0.
- 20 if(f2.lt.0.) go to 30
- p1 = p2
- f1 = f2
- go to 40
- 30 p3 = p2
- f3 = f2
- 40 fprati = p
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpregr.f
===================================================================
--- branches/Interpolate1D/fitpack/fpregr.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpregr.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,367 +0,0 @@
- subroutine fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,
- * nxest,nyest,tol,maxit,nc,nx,tx,ny,ty,c,fp,fp0,fpold,reducx,
- * reducy,fpintx,fpinty,lastdi,nplusx,nplusy,nrx,nry,nrdatx,nrdaty,
- * wrk,lwrk,ier)
-c ..
-c ..scalar arguments..
- real*8 xb,xe,yb,ye,s,tol,fp,fp0,fpold,reducx,reducy
- integer iopt,mx,my,mz,kx,ky,nxest,nyest,maxit,nc,nx,ny,lastdi,
- * nplusx,nplusy,lwrk,ier
-c ..array arguments..
- real*8 x(mx),y(my),z(mz),tx(nxest),ty(nyest),c(nc),fpintx(nxest),
- * fpinty(nyest),wrk(lwrk)
- integer nrdatx(nxest),nrdaty(nyest),nrx(mx),nry(my)
-c ..local scalars
- real*8 acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,half,con1,con9,con4
- integer i,ich1,ich3,ifbx,ifby,ifsx,ifsy,iter,j,kx1,kx2,ky1,ky2,
- * k3,l,lax,lay,lbx,lby,lq,lri,lsx,lsy,mk1,mm,mpm,mynx,ncof,
- * nk1x,nk1y,nmaxx,nmaxy,nminx,nminy,nplx,nply,npl1,nrintx,
- * nrinty,nxe,nxk,nye
-c ..function references..
- real*8 abs,fprati
- integer max0,min0
-c ..subroutine references..
-c fpgrre,fpknot
-c ..
-c set constants
- one = 1
- half = 0.5e0
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
-c we partition the working space.
- kx1 = kx+1
- ky1 = ky+1
- kx2 = kx1+1
- ky2 = ky1+1
- lsx = 1
- lsy = lsx+mx*kx1
- lri = lsy+my*ky1
- mm = max0(nxest,my)
- lq = lri+mm
- mynx = nxest*my
- lax = lq+mynx
- nxk = nxest*kx2
- lbx = lax+nxk
- lay = lbx+nxk
- lby = lay+nyest*ky2
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position. c
-c **************************************************************** c
-c given a set of knots we compute the least-squares spline sinf(x,y), c
-c and the corresponding sum of squared residuals fp=f(p=inf). c
-c if iopt=-1 sinf(x,y) is the requested approximation. c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares spline until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots equals nmaxx = mx+kx+1 and nmaxy = my+ky+1. c
-c if s>0 and c
-c *iopt=0 we first compute the least-squares polynomial of degree c
-c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nymin=2*ky+2. c
-c *iopt=1 we start with the knots found at the last call of the c
-c routine, except for the case that s > fp0; then we can compute c
-c the least-squares polynomial directly. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c determine the number of knots for polynomial approximation.
- nminx = 2*kx1
- nminy = 2*ky1
- if(iopt.lt.0) go to 120
-c acc denotes the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c find nmaxx and nmaxy which denote the number of knots in x- and y-
-c direction in case of spline interpolation.
- nmaxx = mx+kx1
- nmaxy = my+ky1
-c find nxe and nye which denote the maximum number of knots
-c allowed in each direction
- nxe = min0(nmaxx,nxest)
- nye = min0(nmaxy,nyest)
- if(s.gt.0.) go to 100
-c if s = 0, s(x,y) is an interpolating spline.
- nx = nmaxx
- ny = nmaxy
-c test whether the required storage space exceeds the available one.
- if(ny.gt.nyest .or. nx.gt.nxest) go to 420
-c find the position of the interior knots in case of interpolation.
-c the knots in the x-direction.
- mk1 = mx-kx1
- if(mk1.eq.0) go to 60
- k3 = kx/2
- i = kx1+1
- j = k3+2
- if(k3*2.eq.kx) go to 40
- do 30 l=1,mk1
- tx(i) = x(j)
- i = i+1
- j = j+1
- 30 continue
- go to 60
- 40 do 50 l=1,mk1
- tx(i) = (x(j)+x(j-1))*half
- i = i+1
- j = j+1
- 50 continue
-c the knots in the y-direction.
- 60 mk1 = my-ky1
- if(mk1.eq.0) go to 120
- k3 = ky/2
- i = ky1+1
- j = k3+2
- if(k3*2.eq.ky) go to 80
- do 70 l=1,mk1
- ty(i) = y(j)
- i = i+1
- j = j+1
- 70 continue
- go to 120
- 80 do 90 l=1,mk1
- ty(i) = (y(j)+y(j-1))*half
- i = i+1
- j = j+1
- 90 continue
- go to 120
-c if s > 0 our initial choice of knots depends on the value of iopt.
- 100 if(iopt.eq.0) go to 115
- if(fp0.le.s) go to 115
-c if iopt=1 and fp0 > s we start computing the least- squares spline
-c according to the set of knots found at the last call of the routine.
-c we determine the number of grid coordinates x(i) inside each knot
-c interval (tx(l),tx(l+1)).
- l = kx2
- j = 1
- nrdatx(1) = 0
- mpm = mx-1
- do 105 i=2,mpm
- nrdatx(j) = nrdatx(j)+1
- if(x(i).lt.tx(l)) go to 105
- nrdatx(j) = nrdatx(j)-1
- l = l+1
- j = j+1
- nrdatx(j) = 0
- 105 continue
-c we determine the number of grid coordinates y(i) inside each knot
-c interval (ty(l),ty(l+1)).
- l = ky2
- j = 1
- nrdaty(1) = 0
- mpm = my-1
- do 110 i=2,mpm
- nrdaty(j) = nrdaty(j)+1
- if(y(i).lt.ty(l)) go to 110
- nrdaty(j) = nrdaty(j)-1
- l = l+1
- j = j+1
- nrdaty(j) = 0
- 110 continue
- go to 120
-c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
-c polynomial of degree kx in x and ky in y (which is a spline without
-c interior knots).
- 115 nx = nminx
- ny = nminy
- nrdatx(1) = mx-2
- nrdaty(1) = my-2
- lastdi = 0
- nplusx = 0
- nplusy = 0
- fp0 = 0.
- fpold = 0.
- reducx = 0.
- reducy = 0.
- 120 mpm = mx+my
- ifsx = 0
- ifsy = 0
- ifbx = 0
- ifby = 0
- p = -one
-c main loop for the different sets of knots.mpm=mx+my is a save upper
-c bound for the number of trials.
- do 250 iter=1,mpm
- if(nx.eq.nminx .and. ny.eq.nminy) ier = -2
-c find nrintx (nrinty) which is the number of knot intervals in the
-c x-direction (y-direction).
- nrintx = nx-nminx+1
- nrinty = ny-nminy+1
-c find ncof, the number of b-spline coefficients for the current set
-c of knots.
- nk1x = nx-kx1
- nk1y = ny-ky1
- ncof = nk1x*nk1y
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(x,y).
- i = nx
- do 130 j=1,kx1
- tx(j) = xb
- tx(i) = xe
- i = i-1
- 130 continue
- i = ny
- do 140 j=1,ky1
- ty(j) = yb
- ty(i) = ye
- i = i-1
- 140 continue
-c find the least-squares spline sinf(x,y) and calculate for each knot
-c interval tx(j+kx)<=x<=tx(j+kx+1) (ty(j+ky)<=y<=ty(j+ky+1)) the sum
-c of squared residuals fpintx(j),j=1,2,...,nx-2*kx-1 (fpinty(j),j=1,2,
-c ...,ny-2*ky-1) for the data points having their absciss (ordinate)-
-c value belonging to that interval.
-c fp gives the total sum of squared residuals.
- call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty,
- * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx),
- * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby),
- * nrx,nry)
- if(ier.eq.(-2)) fp0 = fp
-c test whether the least-squares spline is an acceptable solution.
- if(iopt.lt.0) go to 440
- fpms = fp-s
- if(abs(fpms) .lt. acc) go to 440
-c if f(p=inf) < s, we accept the choice of knots.
- if(fpms.lt.0.) go to 300
-c if nx=nmaxx and ny=nmaxy, sinf(x,y) is an interpolating spline.
- if(nx.eq.nmaxx .and. ny.eq.nmaxy) go to 430
-c increase the number of knots.
-c if nx=nxe and ny=nye we cannot further increase the number of knots
-c because of the storage capacity limitation.
- if(nx.eq.nxe .and. ny.eq.nye) go to 420
- ier = 0
-c adjust the parameter reducx or reducy according to the direction
-c in which the last added knots were located.
- if (lastdi.lt.0) go to 150
- if (lastdi.eq.0) go to 170
- go to 160
- 150 reducx = fpold-fp
- go to 170
- 160 reducy = fpold-fp
-c store the sum of squared residuals for the current set of knots.
- 170 fpold = fp
-c find nplx, the number of knots we should add in the x-direction.
- nplx = 1
- if(nx.eq.nminx) go to 180
- npl1 = nplusx*2
- rn = nplusx
- if(reducx.gt.acc) npl1 = rn*fpms/reducx
- nplx = min0(nplusx*2,max0(npl1,nplusx/2,1))
-c find nply, the number of knots we should add in the y-direction.
- 180 nply = 1
- if(ny.eq.nminy) go to 190
- npl1 = nplusy*2
- rn = nplusy
- if(reducy.gt.acc) npl1 = rn*fpms/reducy
- nply = min0(nplusy*2,max0(npl1,nplusy/2,1))
- 190 if (nplx.lt.nply) go to 210
- if (nplx.eq.nply) go to 200
- go to 230
- 200 if(lastdi.lt.0) go to 230
- 210 if(nx.eq.nxe) go to 230
-c addition in the x-direction.
- lastdi = -1
- nplusx = nplx
- ifsx = 0
- do 220 l=1,nplusx
-c add a new knot in the x-direction
- call fpknot(x,mx,tx,nx,fpintx,nrdatx,nrintx,nxest,1)
-c test whether we cannot further increase the number of knots in the
-c x-direction.
- if(nx.eq.nxe) go to 250
- 220 continue
- go to 250
- 230 if(ny.eq.nye) go to 210
-c addition in the y-direction.
- lastdi = 1
- nplusy = nply
- ifsy = 0
- do 240 l=1,nplusy
-c add a new knot in the y-direction.
- call fpknot(y,my,ty,ny,fpinty,nrdaty,nrinty,nyest,1)
-c test whether we cannot further increase the number of knots in the
-c y-direction.
- if(ny.eq.nye) go to 250
- 240 continue
-c restart the computations with the new set of knots.
- 250 continue
-c test whether the least-squares polynomial is a solution of our
-c approximation problem.
- 300 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline sp(x,y) c
-c ***************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the b-spline coefficients of the smoothing spline sp(x,y). c
-c this smoothing spline varies with the parameter p in such a way thatc
-c f(p) = sumi=1,mx(sumj=1,my((z(i,j)-sp(x(i),y(j)))**2) c
-c is a continuous, strictly decreasing function of p. moreover the c
-c least-squares polynomial corresponds to p=0 and the least-squares c
-c spline to p=infinity. iteratively we then have to determine the c
-c positive value of p such that f(p)=s. the process which is proposed c
-c here makes use of rational interpolation. f(p) is approximated by a c
-c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c
-c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c
-c are used to calculate the new value of p such that r(p)=s. c
-c convergence is guaranteed by taking f1 > 0 and f3 < 0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = one
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p)=s.
- do 350 iter = 1,maxit
-c find the smoothing spline sp(x,y) and the corresponding sum of
-c squared residuals fp.
- call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty,
- * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx),
- * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby),
- * nrx,nry)
-c test whether the approximation sp(x,y) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 320
- if((f2-f3).gt.acc) go to 310
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 350
- 310 if(f2.lt.0.) ich3 = 1
- 320 if(ich1.ne.0) go to 340
- if((f1-f2).gt.acc) go to 330
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 350
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 350
-c test whether the iteration process proceeds as theoretically
-c expected.
- 330 if(f2.gt.0.) ich1 = 1
- 340 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 350 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- fp = 0.
- 440 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fprota.f
===================================================================
--- branches/Interpolate1D/fitpack/fprota.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fprota.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,14 +0,0 @@
- subroutine fprota(cos,sin,a,b)
-c subroutine fprota applies a givens rotation to a and b.
-c ..
-c ..scalar arguments..
- real*8 cos,sin,a,b
-c ..local scalars..
- real*8 stor1,stor2
-c ..
- stor1 = a
- stor2 = b
- b = cos*stor2+sin*stor1
- a = cos*stor1-sin*stor2
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fprppo.f
===================================================================
--- branches/Interpolate1D/fitpack/fprppo.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fprppo.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,61 +0,0 @@
- subroutine fprppo(nu,nv,if1,if2,cosi,ratio,c,f,ncoff)
-c given the coefficients of a constrained bicubic spline, as determined
-c in subroutine fppola, subroutine fprppo calculates the coefficients
-c in the standard b-spline representation of bicubic splines.
-c ..
-c ..scalar arguments..
- real*8 ratio
- integer nu,nv,if1,if2,ncoff
-c ..array arguments
- real*8 c(ncoff),f(ncoff),cosi(5,nv)
-c ..local scalars..
- integer i,iopt,ii,j,k,l,nu4,nvv
-c ..
- nu4 = nu-4
- nvv = nv-7
- iopt = if1+1
- do 10 i=1,ncoff
- f(i) = 0.
- 10 continue
- i = 0
- do 120 l=1,nu4
- ii = i
- if(l.gt.iopt) go to 80
- go to (20,40,60),l
- 20 do 30 k=1,nvv
- i = i+1
- f(i) = c(1)
- 30 continue
- j = 1
- go to 100
- 40 do 50 k=1,nvv
- i = i+1
- f(i) = c(1)+c(2)*cosi(1,k)+c(3)*cosi(2,k)
- 50 continue
- j = 3
- go to 100
- 60 do 70 k=1,nvv
- i = i+1
- f(i) = c(1)+ratio*(c(2)*cosi(1,k)+c(3)*cosi(2,k))+
- * c(4)*cosi(3,k)+c(5)*cosi(4,k)+c(6)*cosi(5,k)
- 70 continue
- j = 6
- go to 100
- 80 if(l.eq.nu4 .and. if2.ne.0) go to 120
- do 90 k=1,nvv
- i = i+1
- j = j+1
- f(i) = c(j)
- 90 continue
- 100 do 110 k=1,3
- ii = ii+1
- i = i+1
- f(i) = f(ii)
- 110 continue
- 120 continue
- do 130 i=1,ncoff
- c(i) = f(i)
- 130 continue
- return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fprpsp.f
===================================================================
--- branches/Interpolate1D/fitpack/fprpsp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fprpsp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,55 +0,0 @@
- subroutine fprpsp(nt,np,co,si,c,f,ncoff)
-c given the coefficients of a spherical spline function, subroutine
-c fprpsp calculates the coefficients in the standard b-spline re-
-c presentation of this bicubic spline.
-c ..
-c ..scalar arguments
- integer nt,np,ncoff
-c ..array arguments
- real*8 co(np),si(np),c(ncoff),f(ncoff)
-c ..local scalars
- real*8 cn,c1,c2,c3
- integer i,ii,j,k,l,ncof,npp,np4,nt4
-c ..
- nt4 = nt-4
- np4 = np-4
- npp = np4-3
- ncof = 6+npp*(nt4-4)
- c1 = c(1)
- cn = c(ncof)
- j = ncoff
- do 10 i=1,np4
- f(i) = c1
- f(j) = cn
- j = j-1
- 10 continue
- i = np4
- j=1
- do 70 l=3,nt4
- ii = i
- if(l.eq.3 .or. l.eq.nt4) go to 30
- do 20 k=1,npp
- i = i+1
- j = j+1
- f(i) = c(j)
- 20 continue
- go to 50
- 30 if(l.eq.nt4) c1 = cn
- c2 = c(j+1)
- c3 = c(j+2)
- j = j+2
- do 40 k=1,npp
- i = i+1
- f(i) = c1+c2*co(k)+c3*si(k)
- 40 continue
- 50 do 60 k=1,3
- ii = ii+1
- i = i+1
- f(i) = f(ii)
- 60 continue
- 70 continue
- do 80 i=1,ncoff
- c(i) = f(i)
- 80 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpseno.f
===================================================================
--- branches/Interpolate1D/fitpack/fpseno.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpseno.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,34 +0,0 @@
- subroutine fpseno(maxtr,up,left,right,info,merk,ibind,nbind)
-c subroutine fpseno fetches a branch of a triply linked tree the
-c information of which is kept in the arrays up,left,right and info.
-c the branch has a specified length nbind and is determined by the
-c parameter merk which points to its terminal node. the information
-c field of the nodes of this branch is stored in the array ibind. on
-c exit merk points to a new branch of length nbind or takes the value
-c 1 if no such branch was found.
-c ..
-c ..scalar arguments..
- integer maxtr,merk,nbind
-c ..array arguments..
- integer up(maxtr),left(maxtr),right(maxtr),info(maxtr),
- * ibind(nbind)
-c ..scalar arguments..
- integer i,j,k
-c ..
- k = merk
- j = nbind
- do 10 i=1,nbind
- ibind(j) = info(k)
- k = up(k)
- j = j-1
- 10 continue
- 20 k = right(merk)
- if(k.ne.0) go to 30
- merk = up(merk)
- if (merk.le.1) go to 40
- go to 20
- 30 merk = k
- k = left(merk)
- if(k.ne.0) go to 30
- 40 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpspgr.f
===================================================================
--- branches/Interpolate1D/fitpack/fpspgr.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpspgr.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,439 +0,0 @@
- subroutine fpspgr(iopt,ider,u,mu,v,mv,r,mr,r0,r1,s,nuest,nvest,
- * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu,
- * fpintv,dr,step,lastdi,nplusu,nplusv,lastu0,lastu1,nru,nrv,
- * nrdatu,nrdatv,wrk,lwrk,ier)
-c ..
-c ..scalar arguments..
- integer mu,mv,mr,nuest,nvest,maxit,nc,nu,nv,lastdi,nplusu,nplusv,
- * lastu0,lastu1,lwrk,ier
- real*8 r0,r1,s,tol,fp,fp0,fpold,reducu,reducv
-c ..array arguments..
- integer iopt(3),ider(4),nrdatu(nuest),nrdatv(nvest),nru(mu),
- * nrv(mv)
- real*8 u(mu),v(mv),r(mr),tu(nuest),tv(nvest),c(nc),fpintu(nuest),
- * fpintv(nvest),dr(6),wrk(lwrk),step(2)
-c ..local scalars..
- real*8 acc,fpms,f1,f2,f3,p,per,pi,p1,p2,p3,vb,ve,rmax,rmin,rn,one,
- *
- * con1,con4,con9
- integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,istart,iter,i1,i2,j,ju,
- * ktu,l,l1,l2,l3,l4,mpm,mumin,mu0,mu1,nn,nplu,nplv,npl1,nrintu,
- * nrintv,nue,numax,nve,nvmax
-c ..local arrays..
- integer idd(4)
- real*8 drr(6)
-c ..function references..
- real*8 abs,datan2,fprati
- integer max0,min0
-c ..subroutine references..
-c fpknot,fpopsp
-c ..
-c set constants
- one = 1d0
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
-c initialization
- ifsu = 0
- ifsv = 0
- ifbu = 0
- ifbv = 0
- p = -one
- mumin = 4
- if(ider(1).ge.0) mumin = mumin-1
- if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1
- if(ider(3).ge.0) mumin = mumin-1
- if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1
- if(mumin.eq.0) mumin = 1
- pi = datan2(0d0,-one)
- per = pi+pi
- vb = v(1)
- ve = vb+per
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position. c
-c **************************************************************** c
-c given a set of knots we compute the least-squares spline sinf(u,v) c
-c and the corresponding sum of squared residuals fp = f(p=inf). c
-c if iopt(1)=-1 sinf(u,v) is the requested approximation. c
-c if iopt(1)>=0 we check whether we can accept the knots: c
-c if fp <= s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares spline until finally fp <= s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if s=0 we have spline interpolation; in that case the number of c
-c knots in the u-direction equals nu=numax=mu+6+iopt(2)+iopt(3) c
-c and in the v-direction nv=nvmax=mv+7. c
-c if s>0 and c
-c iopt(1)=0 we first compute the least-squares polynomial,i.e. a c
-c spline without interior knots : nu=8 ; nv=8. c
-c iopt(1)=1 we start with the set of knots found at the last call c
-c of the routine, except for the case that s > fp0; then we c
-c compute the least-squares polynomial directly. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- if(iopt(1).lt.0) go to 120
-c acc denotes the absolute tolerance for the root of f(p)=s.
- acc = tol*s
-c numax and nvmax denote the number of knots needed for interpolation.
- numax = mu+6+iopt(2)+iopt(3)
- nvmax = mv+7
- nue = min0(numax,nuest)
- nve = min0(nvmax,nvest)
- if(s.gt.0.) go to 100
-c if s = 0, s(u,v) is an interpolating spline.
- nu = numax
- nv = nvmax
-c test whether the required storage space exceeds the available one.
- if(nu.gt.nuest .or. nv.gt.nvest) go to 420
-c find the position of the knots in the v-direction.
- do 10 l=1,mv
- tv(l+3) = v(l)
- 10 continue
- tv(mv+4) = ve
- l1 = mv-2
- l2 = mv+5
- do 20 i=1,3
- tv(i) = v(l1)-per
- tv(l2) = v(i+1)+per
- l1 = l1+1
- l2 = l2+1
- 20 continue
-c if not all the derivative values g(i,j) are given, we will first
-c estimate these values by computing a least-squares spline
- idd(1) = ider(1)
- if(idd(1).eq.0) idd(1) = 1
- if(idd(1).gt.0) dr(1) = r0
- idd(2) = ider(2)
- idd(3) = ider(3)
- if(idd(3).eq.0) idd(3) = 1
- if(idd(3).gt.0) dr(4) = r1
- idd(4) = ider(4)
- if(ider(1).lt.0 .or. ider(3).lt.0) go to 30
- if(iopt(2).ne.0 .and. ider(2).eq.0) go to 30
- if(iopt(3).eq.0 .or. ider(4).ne.0) go to 70
-c we set up the knots in the u-direction for computing the least-squares
-c spline.
- 30 i1 = 3
- i2 = mu-2
- nu = 4
- do 40 i=1,mu
- if(i1.gt.i2) go to 50
- nu = nu+1
- tu(nu) = u(i1)
- i1 = i1+2
- 40 continue
- 50 do 60 i=1,4
- tu(i) = 0.
- nu = nu+1
- tu(nu) = pi
- 60 continue
-c we compute the least-squares spline for estimating the derivatives.
- call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,idd,
- * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv,
- * wrk,lwrk)
- ifsu = 0
-c if all the derivatives at the origin are known, we compute the
-c interpolating spline.
-c we set up the knots in the u-direction, needed for interpolation.
- 70 nn = numax-8
- if(nn.eq.0) go to 95
- ju = 2-iopt(2)
- do 80 l=1,nn
- tu(l+4) = u(ju)
- ju = ju+1
- 80 continue
- nu = numax
- l = nu
- do 90 i=1,4
- tu(i) = 0.
- tu(l) = pi
- l = l-1
- 90 continue
-c we compute the interpolating spline.
- 95 call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,idd,
- * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv,
- * wrk,lwrk)
- go to 430
-c if s>0 our initial choice of knots depends on the value of iopt(1).
- 100 ier = 0
- if(iopt(1).eq.0) go to 115
- step(1) = -step(1)
- step(2) = -step(2)
- if(fp0.le.s) go to 115
-c if iopt(1)=1 and fp0 > s we start computing the least-squares spline
-c according to the set of knots found at the last call of the routine.
-c we determine the number of grid coordinates u(i) inside each knot
-c interval (tu(l),tu(l+1)).
- l = 5
- j = 1
- nrdatu(1) = 0
- mu0 = 2-iopt(2)
- mu1 = mu-1+iopt(3)
- do 105 i=mu0,mu1
- nrdatu(j) = nrdatu(j)+1
- if(u(i).lt.tu(l)) go to 105
- nrdatu(j) = nrdatu(j)-1
- l = l+1
- j = j+1
- nrdatu(j) = 0
- 105 continue
-c we determine the number of grid coordinates v(i) inside each knot
-c interval (tv(l),tv(l+1)).
- l = 5
- j = 1
- nrdatv(1) = 0
- do 110 i=2,mv
- nrdatv(j) = nrdatv(j)+1
- if(v(i).lt.tv(l)) go to 110
- nrdatv(j) = nrdatv(j)-1
- l = l+1
- j = j+1
- nrdatv(j) = 0
- 110 continue
- idd(1) = ider(1)
- idd(2) = ider(2)
- idd(3) = ider(3)
- idd(4) = ider(4)
- go to 120
-c if iopt(1)=0 or iopt(1)=1 and s >= fp0,we start computing the least-
-c squares polynomial (which is a spline without interior knots).
- 115 ier = -2
- idd(1) = ider(1)
- idd(2) = 1
- idd(3) = ider(3)
- idd(4) = 1
- nu = 8
- nv = 8
- nrdatu(1) = mu-2+iopt(2)+iopt(3)
- nrdatv(1) = mv-1
- lastdi = 0
- nplusu = 0
- nplusv = 0
- fp0 = 0.
- fpold = 0.
- reducu = 0.
- reducv = 0.
-c main loop for the different sets of knots.mpm=mu+mv is a save upper
-c bound for the number of trials.
- 120 mpm = mu+mv
- do 270 iter=1,mpm
-c find nrintu (nrintv) which is the number of knot intervals in the
-c u-direction (v-direction).
- nrintu = nu-7
- nrintv = nv-7
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(u,v).
- i = nu
- do 125 j=1,4
- tu(j) = 0.
- tu(i) = pi
- i = i-1
- 125 continue
- l1 = 4
- l2 = l1
- l3 = nv-3
- l4 = l3
- tv(l2) = vb
- tv(l3) = ve
- do 130 j=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tv(l2) = tv(l4)-per
- tv(l3) = tv(l1)+per
- 130 continue
-c find an estimate of the range of possible values for the optimal
-c derivatives at the origin.
- ktu = nrdatu(1)+2-iopt(2)
- if(ktu.lt.mumin) ktu = mumin
- if(ktu.eq.lastu0) go to 140
- rmin = r0
- rmax = r0
- l = mv*ktu
- do 135 i=1,l
- if(r(i).lt.rmin) rmin = r(i)
- if(r(i).gt.rmax) rmax = r(i)
- 135 continue
- step(1) = rmax-rmin
- lastu0 = ktu
- 140 ktu = nrdatu(nrintu)+2-iopt(3)
- if(ktu.lt.mumin) ktu = mumin
- if(ktu.eq.lastu1) go to 150
- rmin = r1
- rmax = r1
- l = mv*ktu
- j = mr
- do 145 i=1,l
- if(r(j).lt.rmin) rmin = r(j)
- if(r(j).gt.rmax) rmax = r(j)
- j = j-1
- 145 continue
- step(2) = rmax-rmin
- lastu1 = ktu
-c find the least-squares spline sinf(u,v).
- 150 call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,
- * idd,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,
- * nrv,wrk,lwrk)
- if(step(1).lt.0.) step(1) = -step(1)
- if(step(2).lt.0.) step(2) = -step(2)
- if(ier.eq.(-2)) fp0 = fp
-c test whether the least-squares spline is an acceptable solution.
- if(iopt(1).lt.0) go to 440
- fpms = fp-s
- if(abs(fpms) .lt. acc) go to 440
-c if f(p=inf) < s, we accept the choice of knots.
- if(fpms.lt.0.) go to 300
-c if nu=numax and nv=nvmax, sinf(u,v) is an interpolating spline
- if(nu.eq.numax .and. nv.eq.nvmax) go to 430
-c increase the number of knots.
-c if nu=nue and nv=nve we cannot further increase the number of knots
-c because of the storage capacity limitation.
- if(nu.eq.nue .and. nv.eq.nve) go to 420
- if(ider(1).eq.0) fpintu(1) = fpintu(1)+(r0-dr(1))**2
- if(ider(3).eq.0) fpintu(nrintu) = fpintu(nrintu)+(r1-dr(4))**2
- ier = 0
-c adjust the parameter reducu or reducv according to the direction
-c in which the last added knots were located.
- if (lastdi.lt.0) go to 160
- if (lastdi.eq.0) go to 155
- go to 170
- 155 nplv = 3
- idd(2) = ider(2)
- idd(4) = ider(4)
- fpold = fp
- go to 230
- 160 reducu = fpold-fp
- go to 175
- 170 reducv = fpold-fp
-c store the sum of squared residuals for the current set of knots.
- 175 fpold = fp
-c find nplu, the number of knots we should add in the u-direction.
- nplu = 1
- if(nu.eq.8) go to 180
- npl1 = nplusu*2
- rn = nplusu
- if(reducu.gt.acc) npl1 = rn*fpms/reducu
- nplu = min0(nplusu*2,max0(npl1,nplusu/2,1))
-c find nplv, the number of knots we should add in the v-direction.
- 180 nplv = 3
- if(nv.eq.8) go to 190
- npl1 = nplusv*2
- rn = nplusv
- if(reducv.gt.acc) npl1 = rn*fpms/reducv
- nplv = min0(nplusv*2,max0(npl1,nplusv/2,1))
-c test whether we are going to add knots in the u- or v-direction.
- 190 if (nplu.lt.nplv) go to 210
- if (nplu.eq.nplv) go to 200
- go to 230
- 200 if(lastdi.lt.0) go to 230
- 210 if(nu.eq.nue) go to 230
-c addition in the u-direction.
- lastdi = -1
- nplusu = nplu
- ifsu = 0
- istart = 0
- if(iopt(2).eq.0) istart = 1
- do 220 l=1,nplusu
-c add a new knot in the u-direction
- call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,istart)
-c test whether we cannot further increase the number of knots in the
-c u-direction.
- if(nu.eq.nue) go to 270
- 220 continue
- go to 270
- 230 if(nv.eq.nve) go to 210
-c addition in the v-direction.
- lastdi = 1
- nplusv = nplv
- ifsv = 0
- do 240 l=1,nplusv
-c add a new knot in the v-direction.
- call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1)
-c test whether we cannot further increase the number of knots in the
-c v-direction.
- if(nv.eq.nve) go to 270
- 240 continue
-c restart the computations with the new set of knots.
- 270 continue
-c test whether the least-squares polynomial is a solution of our
-c approximation problem.
- 300 if(ier.eq.(-2)) go to 440
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline sp(u,v) c
-c ***************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the b-spline coefficients of the smoothing spline sp(u,v). c
-c this smoothing spline depends on the parameter p in such a way that c
-c f(p) = sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c
-c is a continuous, strictly decreasing function of p. moreover the c
-c least-squares polynomial corresponds to p=0 and the least-squares c
-c spline to p=infinity. then iteratively we have to determine the c
-c positive value of p such that f(p)=s. the process which is proposed c
-c here makes use of rational interpolation. f(p) is approximated by a c
-c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c
-c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c
-c are used to calculate the new value of p such that r(p)=s. c
-c convergence is guaranteed by taking f1 > 0 and f3 < 0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c initial value for p.
- p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = one
- do 305 i=1,6
- drr(i) = dr(i)
- 305 continue
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p)=s.
- do 350 iter = 1,maxit
-c find the smoothing spline sp(u,v) and the corresponding sum f(p).
- call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,drr,iopt,
- * idd,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,
- * nrv,wrk,lwrk)
-c test whether the approximation sp(u,v) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).lt.acc) go to 440
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 400
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 320
- if((f2-f3).gt.acc) go to 310
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 350
- 310 if(f2.lt.0.) ich3 = 1
- 320 if(ich1.ne.0) go to 340
- if((f1-f2).gt.acc) go to 330
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 350
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 350
-c test whether the iteration process proceeds as theoretically
-c expected.
- 330 if(f2.gt.0.) ich1 = 1
- 340 if(f2.ge.f1 .or. f2.le.f3) go to 410
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 350 continue
-c error codes and messages.
- 400 ier = 3
- go to 440
- 410 ier = 2
- go to 440
- 420 ier = 1
- go to 440
- 430 ier = -1
- fp = 0.
- 440 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpsphe.f
===================================================================
--- branches/Interpolate1D/fitpack/fpsphe.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpsphe.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,764 +0,0 @@
- subroutine fpsphe(iopt,m,teta,phi,r,w,s,ntest,npest,eta,tol,maxit,
- *
- * ib1,ib3,nc,ncc,intest,nrest,nt,tt,np,tp,c,fp,sup,fpint,coord,f,
- * ff,row,coco,cosi,a,q,bt,bp,spt,spp,h,index,nummer,wrk,lwrk,ier)
-c ..
-c ..scalar arguments..
- integer iopt,m,ntest,npest,maxit,ib1,ib3,nc,ncc,intest,nrest,
- * nt,np,lwrk,ier
- real*8 s,eta,tol,fp,sup
-c ..array arguments..
- real*8 teta(m),phi(m),r(m),w(m),tt(ntest),tp(npest),c(nc),
- * fpint(intest),coord(intest),f(ncc),ff(nc),row(npest),coco(npest),
- *
- * cosi(npest),a(ncc,ib1),q(ncc,ib3),bt(ntest,5),bp(npest,5),
- * spt(m,4),spp(m,4),h(ib3),wrk(lwrk)
- integer index(nrest),nummer(m)
-c ..local scalars..
- real*8 aa,acc,arg,cn,co,c1,dmax,d1,d2,eps,facc,facs,fac1,fac2,fn,
- * fpmax,fpms,f1,f2,f3,hti,htj,p,pi,pinv,piv,pi2,p1,p2,p3,ri,si,
- * sigma,sq,store,wi,rn,one,con1,con9,con4,half,ten
- integer i,iband,iband1,iband3,iband4,ich1,ich3,ii,ij,il,in,irot,
- * iter,i1,i2,i3,j,jlt,jrot,j1,j2,l,la,lf,lh,ll,lp,lt,lwest,l1,l2,
- * l3,l4,ncof,ncoff,npp,np4,nreg,nrint,nrr,nr1,ntt,nt4,nt6,num,
- * num1,rank
-c ..local arrays..
- real*8 ht(4),hp(4)
-c ..function references..
- real*8 abs,atan,fprati,sqrt,cos,sin
- integer min0
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota,fprpsp
-c ..
-c set constants
- one = 0.1e+01
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- half = 0.5e0
- ten = 0.1e+02
- pi = atan(one)*4
- pi2 = pi+pi
- eps = sqrt(eta)
- if(iopt.lt.0) go to 70
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
- if(iopt.eq.0) go to 10
- if(s.lt.sup) then
- if (np.lt.11) go to 60
- go to 70
- endif
-c if iopt=0 we begin by computing the weighted least-squares polynomial
-c of the form
-c s(teta,phi) = c1*f1(teta) + cn*fn(teta)
-c where f1(teta) and fn(teta) are the cubic polynomials satisfying
-c f1(0) = 1, f1(pi) = f1'(0) = f1'(pi) = 0 ; fn(teta) = 1-f1(teta).
-c the corresponding weighted sum of squared residuals gives the upper
-c bound sup for the smoothing factor s.
- 10 sup = 0.
- d1 = 0.
- d2 = 0.
- c1 = 0.
- cn = 0.
- fac1 = pi*(one + half)
- fac2 = (one + one)/pi**3
- aa = 0.
- do 40 i=1,m
- wi = w(i)
- ri = r(i)*wi
- arg = teta(i)
- fn = fac2*arg*arg*(fac1-arg)
- f1 = (one-fn)*wi
- fn = fn*wi
- if(fn.eq.0.) go to 20
- call fpgivs(fn,d1,co,si)
- call fprota(co,si,f1,aa)
- call fprota(co,si,ri,cn)
- 20 if(f1.eq.0.) go to 30
- call fpgivs(f1,d2,co,si)
- call fprota(co,si,ri,c1)
- 30 sup = sup+ri*ri
- 40 continue
- if(d2.ne.0.) c1 = c1/d2
- if(d1.ne.0.) cn = (cn-aa*c1)/d1
-c find the b-spline representation of this least-squares polynomial
- nt = 8
- np = 8
- do 50 i=1,4
- c(i) = c1
- c(i+4) = c1
- c(i+8) = cn
- c(i+12) = cn
- tt(i) = 0.
- tt(i+4) = pi
- tp(i) = 0.
- tp(i+4) = pi2
- 50 continue
- fp = sup
-c test whether the least-squares polynomial is an acceptable solution
- fpms = sup-s
- if(fpms.lt.acc) go to 960
-c test whether we cannot further increase the number of knots.
- 60 if(npest.lt.11 .or. ntest.lt.9) go to 950
-c find the initial set of interior knots of the spherical spline in
-c case iopt = 0.
- np = 11
- tp(5) = pi*half
- tp(6) = pi
- tp(7) = tp(5)+pi
- nt = 9
- tt(5) = tp(5)
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1 : computation of least-squares spherical splines. c
-c ******************************************************** c
-c if iopt < 0 we compute the least-squares spherical spline according c
-c to the given set of knots. c
-c if iopt >=0 we compute least-squares spherical splines with increas-c
-c ing numbers of knots until the corresponding sum f(p=inf)<=s. c
-c the initial set of knots then depends on the value of iopt: c
-c if iopt=0 we start with one interior knot in the teta-direction c
-c (pi/2) and three in the phi-direction (pi/2,pi,3*pi/2). c
-c if iopt>0 we start with the set of knots found at the last call c
-c of the routine. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c main loop for the different sets of knots. m is a save upper bound
-c for the number of trials.
- 70 do 570 iter=1,m
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(teta,phi).
- l1 = 4
- l2 = l1
- l3 = np-3
- l4 = l3
- tp(l2) = 0.
- tp(l3) = pi2
- do 80 i=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tp(l2) = tp(l4)-pi2
- tp(l3) = tp(l1)+pi2
- 80 continue
- l = nt
- do 90 i=1,4
- tt(i) = 0.
- tt(l) = pi
- l = l-1
- 90 continue
-c find nrint, the total number of knot intervals and nreg, the number
-c of panels in which the approximation domain is subdivided by the
-c intersection of knots.
- ntt = nt-7
- npp = np-7
- nrr = npp/2
- nr1 = nrr+1
- nrint = ntt+npp
- nreg = ntt*npp
-c arrange the data points according to the panel they belong to.
- call fporde(teta,phi,m,3,3,tt,nt,tp,np,nummer,index,nreg)
-c find the b-spline coefficients coco and cosi of the cubic spline
-c approximations sc(phi) and ss(phi) for cos(phi) and sin(phi).
- do 100 i=1,npp
- coco(i) = 0.
- cosi(i) = 0.
- do 100 j=1,npp
- a(i,j) = 0.
- 100 continue
-c the coefficients coco and cosi are obtained from the conditions
-c sc(tp(i))=cos(tp(i)),resp. ss(tp(i))=sin(tp(i)),i=4,5,...np-4.
- do 150 i=1,npp
- l2 = i+3
- arg = tp(l2)
- call fpbspl(tp,np,3,arg,l2,hp)
- do 110 j=1,npp
- row(j) = 0.
- 110 continue
- ll = i
- do 120 j=1,3
- if(ll.gt.npp) ll= 1
- row(ll) = row(ll)+hp(j)
- ll = ll+1
- 120 continue
- facc = cos(arg)
- facs = sin(arg)
- do 140 j=1,npp
- piv = row(j)
- if(piv.eq.0.) go to 140
- call fpgivs(piv,a(j,1),co,si)
- call fprota(co,si,facc,coco(j))
- call fprota(co,si,facs,cosi(j))
- if(j.eq.npp) go to 150
- j1 = j+1
- i2 = 1
- do 130 l=j1,npp
- i2 = i2+1
- call fprota(co,si,row(l),a(j,i2))
- 130 continue
- 140 continue
- 150 continue
- call fpback(a,coco,npp,npp,coco,ncc)
- call fpback(a,cosi,npp,npp,cosi,ncc)
-c find ncof, the dimension of the spherical spline and ncoff, the
-c number of coefficients in the standard b-spline representation.
- nt4 = nt-4
- np4 = np-4
- ncoff = nt4*np4
- ncof = 6+npp*(ntt-1)
-c find the bandwidth of the observation matrix a.
- iband = 4*npp
- if(ntt.eq.4) iband = 3*(npp+1)
- if(ntt.lt.4) iband = ncof
- iband1 = iband-1
-c initialize the observation matrix a.
- do 160 i=1,ncof
- f(i) = 0.
- do 160 j=1,iband
- a(i,j) = 0.
- 160 continue
-c initialize the sum of squared residuals.
- fp = 0.
-c fetch the data points in the new order. main loop for the
-c different panels.
- do 340 num=1,nreg
-c fix certain constants for the current panel; jrot records the column
-c number of the first non-zero element in a row of the observation
-c matrix according to a data point of the panel.
- num1 = num-1
- lt = num1/npp
- l1 = lt+4
- lp = num1-lt*npp+1
- l2 = lp+3
- lt = lt+1
- jrot = 0
- if(lt.gt.2) jrot = 3+(lt-3)*npp
-c test whether there are still data points in the current panel.
- in = index(num)
- 170 if(in.eq.0) go to 340
-c fetch a new data point.
- wi = w(in)
- ri = r(in)*wi
-c evaluate for the teta-direction, the 4 non-zero b-splines at teta(in)
- call fpbspl(tt,nt,3,teta(in),l1,ht)
-c evaluate for the phi-direction, the 4 non-zero b-splines at phi(in)
- call fpbspl(tp,np,3,phi(in),l2,hp)
-c store the value of these b-splines in spt and spp resp.
- do 180 i=1,4
- spp(in,i) = hp(i)
- spt(in,i) = ht(i)
- 180 continue
-c initialize the new row of observation matrix.
- do 190 i=1,iband
- h(i) = 0.
- 190 continue
-c calculate the non-zero elements of the new row by making the cross
-c products of the non-zero b-splines in teta- and phi-direction and
-c by taking into account the conditions of the spherical splines.
- do 200 i=1,npp
- row(i) = 0.
- 200 continue
-c take into account the condition (3) of the spherical splines.
- ll = lp
- do 210 i=1,4
- if(ll.gt.npp) ll=1
- row(ll) = row(ll)+hp(i)
- ll = ll+1
- 210 continue
-c take into account the other conditions of the spherical splines.
- if(lt.gt.2 .and. lt.lt.(ntt-1)) go to 230
- facc = 0.
- facs = 0.
- do 220 i=1,npp
- facc = facc+row(i)*coco(i)
- facs = facs+row(i)*cosi(i)
- 220 continue
-c fill in the non-zero elements of the new row.
- 230 j1 = 0
- do 280 j =1,4
- jlt = j+lt
- htj = ht(j)
- if(jlt.gt.2 .and. jlt.le.nt4) go to 240
- j1 = j1+1
- h(j1) = h(j1)+htj
- go to 280
- 240 if(jlt.eq.3 .or. jlt.eq.nt4) go to 260
- do 250 i=1,npp
- j1 = j1+1
- h(j1) = row(i)*htj
- 250 continue
- go to 280
- 260 if(jlt.eq.3) go to 270
- h(j1+1) = facc*htj
- h(j1+2) = facs*htj
- h(j1+3) = htj
- j1 = j1+2
- go to 280
- 270 h(1) = h(1)+htj
- h(2) = facc*htj
- h(3) = facs*htj
- j1 = 3
- 280 continue
- do 290 i=1,iband
- h(i) = h(i)*wi
- 290 continue
-c rotate the row into triangle by givens transformations.
- irot = jrot
- do 310 i=1,iband
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 310
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(irot,1),co,si)
-c apply that transformation to the right hand side.
- call fprota(co,si,ri,f(irot))
- if(i.eq.iband) go to 320
-c apply that transformation to the left hand side.
- i2 = 1
- i3 = i+1
- do 300 j=i3,iband
- i2 = i2+1
- call fprota(co,si,h(j),a(irot,i2))
- 300 continue
- 310 continue
-c add the contribution of the row to the sum of squares of residual
-c right hand sides.
- 320 fp = fp+ri**2
-c find the number of the next data point in the panel.
- 330 in = nummer(in)
- go to 170
- 340 continue
-c find dmax, the maximum value for the diagonal elements in the reduced
-c triangle.
- dmax = 0.
- do 350 i=1,ncof
- if(a(i,1).le.dmax) go to 350
- dmax = a(i,1)
- 350 continue
-c check whether the observation matrix is rank deficient.
- sigma = eps*dmax
- do 360 i=1,ncof
- if(a(i,1).le.sigma) go to 370
- 360 continue
-c backward substitution in case of full rank.
- call fpback(a,f,ncof,iband,c,ncc)
- rank = ncof
- do 365 i=1,ncof
- q(i,1) = a(i,1)/dmax
- 365 continue
- go to 390
-c in case of rank deficiency, find the minimum norm solution.
- 370 lwest = ncof*iband+ncof+iband
- if(lwrk.lt.lwest) go to 925
- lf = 1
- lh = lf+ncof
- la = lh+iband
- do 380 i=1,ncof
- ff(i) = f(i)
- do 380 j=1,iband
- q(i,j) = a(i,j)
- 380 continue
- call fprank(q,ff,ncof,iband,ncc,sigma,c,sq,rank,wrk(la),
- * wrk(lf),wrk(lh))
- do 385 i=1,ncof
- q(i,1) = q(i,1)/dmax
- 385 continue
-c add to the sum of squared residuals, the contribution of reducing
-c the rank.
- fp = fp+sq
-c find the coefficients in the standard b-spline representation of
-c the spherical spline.
- 390 call fprpsp(nt,np,coco,cosi,c,ff,ncoff)
-c test whether the least-squares spline is an acceptable solution.
- if(iopt.lt.0) then
- if (fp.le.0) go to 970
- go to 980
- endif
- fpms = fp-s
- if(abs(fpms).le.acc) then
- if (fp.le.0) go to 970
- go to 980
- endif
-c if f(p=inf) < s, accept the choice of knots.
- if(fpms.lt.0.) go to 580
-c test whether we cannot further increase the number of knots.
- if(ncof.gt.m) go to 935
-c search where to add a new knot.
-c find for each interval the sum of squared residuals fpint for the
-c data points having the coordinate belonging to that knot interval.
-c calculate also coord which is the same sum, weighted by the position
-c of the data points considered.
- 440 do 450 i=1,nrint
- fpint(i) = 0.
- coord(i) = 0.
- 450 continue
- do 490 num=1,nreg
- num1 = num-1
- lt = num1/npp
- l1 = lt+1
- lp = num1-lt*npp
- l2 = lp+1+ntt
- jrot = lt*np4+lp
- in = index(num)
- 460 if(in.eq.0) go to 490
- store = 0.
- i1 = jrot
- do 480 i=1,4
- hti = spt(in,i)
- j1 = i1
- do 470 j=1,4
- j1 = j1+1
- store = store+hti*spp(in,j)*c(j1)
- 470 continue
- i1 = i1+np4
- 480 continue
- store = (w(in)*(r(in)-store))**2
- fpint(l1) = fpint(l1)+store
- coord(l1) = coord(l1)+store*teta(in)
- fpint(l2) = fpint(l2)+store
- coord(l2) = coord(l2)+store*phi(in)
- in = nummer(in)
- go to 460
- 490 continue
-c find the interval for which fpint is maximal on the condition that
-c there still can be added a knot.
- l1 = 1
- l2 = nrint
- if(ntest.lt.nt+1) l1=ntt+1
- if(npest.lt.np+2) l2=ntt
-c test whether we cannot further increase the number of knots.
- if(l1.gt.l2) go to 950
- 500 fpmax = 0.
- l = 0
- do 510 i=l1,l2
- if(fpmax.ge.fpint(i)) go to 510
- l = i
- fpmax = fpint(i)
- 510 continue
- if(l.eq.0) go to 930
-c calculate the position of the new knot.
- arg = coord(l)/fpint(l)
-c test in what direction the new knot is going to be added.
- if(l.gt.ntt) go to 530
-c addition in the teta-direction
- l4 = l+4
- fpint(l) = 0.
- fac1 = tt(l4)-arg
- fac2 = arg-tt(l4-1)
- if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500
- j = nt
- do 520 i=l4,nt
- tt(j+1) = tt(j)
- j = j-1
- 520 continue
- tt(l4) = arg
- nt = nt+1
- go to 570
-c addition in the phi-direction
- 530 l4 = l+4-ntt
- if(arg.lt.pi) go to 540
- arg = arg-pi
- l4 = l4-nrr
- 540 fpint(l) = 0.
- fac1 = tp(l4)-arg
- fac2 = arg-tp(l4-1)
- if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500
- ll = nrr+4
- j = ll
- do 550 i=l4,ll
- tp(j+1) = tp(j)
- j = j-1
- 550 continue
- tp(l4) = arg
- np = np+2
- nrr = nrr+1
- do 560 i=5,ll
- j = i+nrr
- tp(j) = tp(i)+pi
- 560 continue
-c restart the computations with the new set of knots.
- 570 continue
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spherical spline. c
-c ******************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the coefficients of the smoothing spline sp(teta,phi). c
-c the observation matrix a is extended by the rows of a matrix, expres-c
-c sing that sp(teta,phi) must be a constant function in the variable c
-c phi and a cubic polynomial in the variable teta. the corresponding c
-c weights of these additional rows are set to 1/(p). iteratively c
-c we than have to determine the value of p such that f(p) = sum((w(i)* c
-c (r(i)-sp(teta(i),phi(i))))**2) be = s. c
-c we already know that the least-squares polynomial corresponds to p=0,c
-c and that the least-squares spherical spline corresponds to p=infin. c
-c the iteration process makes use of rational interpolation. since f(p)c
-c is a convex and strictly decreasing function of p, it can be approx- c
-c imated by a rational function of the form r(p) = (u*p+v)/(p+w). c
-c three values of p (p1,p2,p3) with corresponding values of f(p) (f1= c
-c f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the new value c
-c of p such that r(p)=s. convergence is guaranteed by taking f1>0,f3<0.c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c evaluate the discontinuity jumps of the 3-th order derivative of
-c the b-splines at the knots tt(l),l=5,...,nt-4.
- 580 call fpdisc(tt,nt,5,bt,ntest)
-c evaluate the discontinuity jumps of the 3-th order derivative of
-c the b-splines at the knots tp(l),l=5,...,np-4.
- call fpdisc(tp,np,5,bp,npest)
-c initial value for p.
- p1 = 0.
- f1 = sup-s
- p3 = -one
- f3 = fpms
- p = 0.
- do 585 i=1,ncof
- p = p+a(i,1)
- 585 continue
- rn = ncof
- p = rn/p
-c find the bandwidth of the extended observation matrix.
- iband4 = iband+3
- if(ntt.le.4) iband4 = ncof
- iband3 = iband4 -1
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p)=s.
- do 920 iter=1,maxit
- pinv = one/p
-c store the triangularized observation matrix into q.
- do 600 i=1,ncof
- ff(i) = f(i)
- do 590 j=1,iband4
- q(i,j) = 0.
- 590 continue
- do 600 j=1,iband
- q(i,j) = a(i,j)
- 600 continue
-c extend the observation matrix with the rows of a matrix, expressing
-c that for teta=cst. sp(teta,phi) must be a constant function.
- nt6 = nt-6
- do 720 i=5,np4
- ii = i-4
- do 610 l=1,npp
- row(l) = 0.
- 610 continue
- ll = ii
- do 620 l=1,5
- if(ll.gt.npp) ll=1
- row(ll) = row(ll)+bp(ii,l)
- ll = ll+1
- 620 continue
- facc = 0.
- facs = 0.
- do 630 l=1,npp
- facc = facc+row(l)*coco(l)
- facs = facs+row(l)*cosi(l)
- 630 continue
- do 720 j=1,nt6
-c initialize the new row.
- do 640 l=1,iband
- h(l) = 0.
- 640 continue
-c fill in the non-zero elements of the row. jrot records the column
-c number of the first non-zero element in the row.
- jrot = 4+(j-2)*npp
- if(j.gt.1 .and. j.lt.nt6) go to 650
- h(1) = facc
- h(2) = facs
- if(j.eq.1) jrot = 2
- go to 670
- 650 do 660 l=1,npp
- h(l)=row(l)
- 660 continue
- 670 do 675 l=1,iband
- h(l) = h(l)*pinv
- 675 continue
- ri = 0.
-c rotate the new row into triangle by givens transformations.
- do 710 irot=jrot,ncof
- piv = h(1)
- i2 = min0(iband1,ncof-irot)
- if(piv.eq.0.) then
- if (i2.le.0) go to 720
- go to 690
- endif
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,q(irot,1),co,si)
-c apply that givens transformation to the right hand side.
- call fprota(co,si,ri,ff(irot))
- if(i2.eq.0) go to 720
-c apply that givens transformation to the left hand side.
- do 680 l=1,i2
- l1 = l+1
- call fprota(co,si,h(l1),q(irot,l1))
- 680 continue
- 690 do 700 l=1,i2
- h(l) = h(l+1)
- 700 continue
- h(i2+1) = 0.
- 710 continue
- 720 continue
-c extend the observation matrix with the rows of a matrix expressing
-c that for phi=cst. sp(teta,phi) must be a cubic polynomial.
- do 810 i=5,nt4
- ii = i-4
- do 810 j=1,npp
-c initialize the new row
- do 730 l=1,iband4
- h(l) = 0.
- 730 continue
-c fill in the non-zero elements of the row. jrot records the column
-c number of the first non-zero element in the row.
- j1 = 1
- do 760 l=1,5
- il = ii+l
- ij = npp
- if(il.ne.3 .and. il.ne.nt4) go to 750
- j1 = j1+3-j
- j2 = j1-2
- ij = 0
- if(il.ne.3) go to 740
- j1 = 1
- j2 = 2
- ij = j+2
- 740 h(j2) = bt(ii,l)*coco(j)
- h(j2+1) = bt(ii,l)*cosi(j)
- 750 h(j1) = h(j1)+bt(ii,l)
- j1 = j1+ij
- 760 continue
- do 765 l=1,iband4
- h(l) = h(l)*pinv
- 765 continue
- ri = 0.
- jrot = 1
- if(ii.gt.2) jrot = 3+j+(ii-3)*npp
-c rotate the new row into triangle by givens transformations.
- do 800 irot=jrot,ncof
- piv = h(1)
- i2 = min0(iband3,ncof-irot)
- if(piv.eq.0.) then
- if (i2.le.0) go to 810
- go to 780
- endif
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,q(irot,1),co,si)
-c apply that givens transformation to the right hand side.
- call fprota(co,si,ri,ff(irot))
- if(i2.eq.0) go to 810
-c apply that givens transformation to the left hand side.
- do 770 l=1,i2
- l1 = l+1
- call fprota(co,si,h(l1),q(irot,l1))
- 770 continue
- 780 do 790 l=1,i2
- h(l) = h(l+1)
- 790 continue
- h(i2+1) = 0.
- 800 continue
- 810 continue
-c find dmax, the maximum value for the diagonal elements in the
-c reduced triangle.
- dmax = 0.
- do 820 i=1,ncof
- if(q(i,1).le.dmax) go to 820
- dmax = q(i,1)
- 820 continue
-c check whether the matrix is rank deficient.
- sigma = eps*dmax
- do 830 i=1,ncof
- if(q(i,1).le.sigma) go to 840
- 830 continue
-c backward substitution in case of full rank.
- call fpback(q,ff,ncof,iband4,c,ncc)
- rank = ncof
- go to 845
-c in case of rank deficiency, find the minimum norm solution.
- 840 lwest = ncof*iband4+ncof+iband4
- if(lwrk.lt.lwest) go to 925
- lf = 1
- lh = lf+ncof
- la = lh+iband4
- call fprank(q,ff,ncof,iband4,ncc,sigma,c,sq,rank,wrk(la),
- * wrk(lf),wrk(lh))
- 845 do 850 i=1,ncof
- q(i,1) = q(i,1)/dmax
- 850 continue
-c find the coefficients in the standard b-spline representation of
-c the spherical spline.
- call fprpsp(nt,np,coco,cosi,c,ff,ncoff)
-c compute f(p).
- fp = 0.
- do 890 num = 1,nreg
- num1 = num-1
- lt = num1/npp
- lp = num1-lt*npp
- jrot = lt*np4+lp
- in = index(num)
- 860 if(in.eq.0) go to 890
- store = 0.
- i1 = jrot
- do 880 i=1,4
- hti = spt(in,i)
- j1 = i1
- do 870 j=1,4
- j1 = j1+1
- store = store+hti*spp(in,j)*c(j1)
- 870 continue
- i1 = i1+np4
- 880 continue
- fp = fp+(w(in)*(r(in)-store))**2
- in = nummer(in)
- go to 860
- 890 continue
-c test whether the approximation sp(teta,phi) is an acceptable solution
- fpms = fp-s
- if(abs(fpms).le.acc) go to 980
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 940
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 900
- if((f2-f3).gt.acc) go to 895
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 920
- 895 if(f2.lt.0.) ich3 = 1
- 900 if(ich1.ne.0) go to 910
- if((f1-f2).gt.acc) go to 905
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 920
- if(p.ge.p3) p = p2*con1 +p3*con9
- go to 920
- 905 if(f2.gt.0.) ich1 = 1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 910 if(f2.ge.f1 .or. f2.le.f3) go to 945
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 920 continue
-c error codes and messages.
- 925 ier = lwest
- go to 990
- 930 ier = 5
- go to 990
- 935 ier = 4
- go to 990
- 940 ier = 3
- go to 990
- 945 ier = 2
- go to 990
- 950 ier = 1
- go to 990
- 960 ier = -2
- go to 990
- 970 ier = -1
- fp = 0.
- 980 if(ncof.ne.rank) ier = -rank
- 990 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpsuev.f
===================================================================
--- branches/Interpolate1D/fitpack/fpsuev.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpsuev.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,80 +0,0 @@
- subroutine fpsuev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,wu,wv,lu,lv)
-c ..scalar arguments..
- integer idim,nu,nv,mu,mv
-c ..array arguments..
- integer lu(mu),lv(mv)
- real*8 tu(nu),tv(nv),c((nu-4)*(nv-4)*idim),u(mu),v(mv),
- * f(mu*mv*idim),wu(mu,4),wv(mv,4)
-c ..local scalars..
- integer i,i1,j,j1,k,l,l1,l2,l3,m,nuv,nu4,nv4
- real*8 arg,sp,tb,te
-c ..local arrays..
- real*8 h(4)
-c ..subroutine references..
-c fpbspl
-c ..
- nu4 = nu-4
- tb = tu(4)
- te = tu(nu4+1)
- l = 4
- l1 = l+1
- do 40 i=1,mu
- arg = u(i)
- if(arg.lt.tb) arg = tb
- if(arg.gt.te) arg = te
- 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20
- l = l1
- l1 = l+1
- go to 10
- 20 call fpbspl(tu,nu,3,arg,l,h)
- lu(i) = l-4
- do 30 j=1,4
- wu(i,j) = h(j)
- 30 continue
- 40 continue
- nv4 = nv-4
- tb = tv(4)
- te = tv(nv4+1)
- l = 4
- l1 = l+1
- do 80 i=1,mv
- arg = v(i)
- if(arg.lt.tb) arg = tb
- if(arg.gt.te) arg = te
- 50 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 60
- l = l1
- l1 = l+1
- go to 50
- 60 call fpbspl(tv,nv,3,arg,l,h)
- lv(i) = l-4
- do 70 j=1,4
- wv(i,j) = h(j)
- 70 continue
- 80 continue
- m = 0
- nuv = nu4*nv4
- do 140 k=1,idim
- l3 = (k-1)*nuv
- do 130 i=1,mu
- l = lu(i)*nv4+l3
- do 90 i1=1,4
- h(i1) = wu(i,i1)
- 90 continue
- do 120 j=1,mv
- l1 = l+lv(j)
- sp = 0.
- do 110 i1=1,4
- l2 = l1
- do 100 j1=1,4
- l2 = l2+1
- sp = sp+c(l2)*h(i1)*wv(j,j1)
- 100 continue
- l1 = l1+nv4
- 110 continue
- m = m+1
- f(m) = sp
- 120 continue
- 130 continue
- 140 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpsurf.f
===================================================================
--- branches/Interpolate1D/fitpack/fpsurf.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpsurf.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,680 +0,0 @@
- subroutine fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kxx,kyy,s,nxest,
- * nyest,eta,tol,maxit,nmax,km1,km2,ib1,ib3,nc,intest,nrest,
- * nx0,tx,ny0,ty,c,fp,fp0,fpint,coord,f,ff,a,q,bx,by,spx,spy,h,
- * index,nummer,wrk,lwrk,ier)
-c ..
-c ..scalar arguments..
- real*8 xb,xe,yb,ye,s,eta,tol,fp,fp0
- integer iopt,m,kxx,kyy,nxest,nyest,maxit,nmax,km1,km2,ib1,ib3,
- * nc,intest,nrest,nx0,ny0,lwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax),c(nc),fpint(intest),
- * coord(intest),f(nc),ff(nc),a(nc,ib1),q(nc,ib3),bx(nmax,km2),
- * by(nmax,km2),spx(m,km1),spy(m,km1),h(ib3),wrk(lwrk)
- integer index(nrest),nummer(m)
-c ..local scalars..
- real*8 acc,arg,cos,dmax,fac1,fac2,fpmax,fpms,f1,f2,f3,hxi,p,pinv,
- * piv,p1,p2,p3,sigma,sin,sq,store,wi,x0,x1,y0,y1,zi,eps,
- * rn,one,con1,con9,con4,half,ten
- integer i,iband,iband1,iband3,iband4,ibb,ichang,ich1,ich3,ii,
- * in,irot,iter,i1,i2,i3,j,jrot,jxy,j1,kx,kx1,kx2,ky,ky1,ky2,l,
- * la,lf,lh,lwest,lx,ly,l1,l2,n,ncof,nk1x,nk1y,nminx,nminy,nreg,
- * nrint,num,num1,nx,nxe,nxx,ny,nye,nyy,n1,rank
-c ..local arrays..
- real*8 hx(6),hy(6)
-c ..function references..
- real*8 abs,fprati,sqrt
- integer min0
-c ..subroutine references..
-c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota
-c ..
-c set constants
- one = 0.1e+01
- con1 = 0.1e0
- con9 = 0.9e0
- con4 = 0.4e-01
- half = 0.5e0
- ten = 0.1e+02
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position. c
-c **************************************************************** c
-c given a set of knots we compute the least-squares spline sinf(x,y), c
-c and the corresponding weighted sum of squared residuals fp=f(p=inf). c
-c if iopt=-1 sinf(x,y) is the requested approximation. c
-c if iopt=0 or iopt=1 we check whether we can accept the knots: c
-c if fp <=s we will continue with the current set of knots. c
-c if fp > s we will increase the number of knots and compute the c
-c corresponding least-squares spline until finally fp<=s. c
-c the initial choice of knots depends on the value of s and iopt. c
-c if iopt=0 we first compute the least-squares polynomial of degree c
-c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nminy=2*ky+2. c
-c fp0=f(0) denotes the corresponding weighted sum of squared c
-c residuals c
-c if iopt=1 we start with the knots found at the last call of the c
-c routine, except for the case that s>=fp0; then we can compute c
-c the least-squares polynomial directly. c
-c eventually the independent variables x and y (and the corresponding c
-c parameters) will be switched if this can reduce the bandwidth of the c
-c system to be solved. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c ichang denotes whether(1) or not(-1) the directions have been inter-
-c changed.
- ichang = -1
- x0 = xb
- x1 = xe
- y0 = yb
- y1 = ye
- kx = kxx
- ky = kyy
- kx1 = kx+1
- ky1 = ky+1
- nxe = nxest
- nye = nyest
- eps = sqrt(eta)
- if(iopt.lt.0) go to 20
-c calculation of acc, the absolute tolerance for the root of f(p)=s.
- acc = tol*s
- if(iopt.eq.0) go to 10
- if(fp0.gt.s) go to 20
-c initialization for the least-squares polynomial.
- 10 nminx = 2*kx1
- nminy = 2*ky1
- nx = nminx
- ny = nminy
- ier = -2
- go to 30
- 20 nx = nx0
- ny = ny0
-c main loop for the different sets of knots. m is a save upper bound
-c for the number of trials.
- 30 do 420 iter=1,m
-c find the position of the additional knots which are needed for the
-c b-spline representation of s(x,y).
- l = nx
- do 40 i=1,kx1
- tx(i) = x0
- tx(l) = x1
- l = l-1
- 40 continue
- l = ny
- do 50 i=1,ky1
- ty(i) = y0
- ty(l) = y1
- l = l-1
- 50 continue
-c find nrint, the total number of knot intervals and nreg, the number
-c of panels in which the approximation domain is subdivided by the
-c intersection of knots.
- nxx = nx-2*kx1+1
- nyy = ny-2*ky1+1
- nrint = nxx+nyy
- nreg = nxx*nyy
-c find the bandwidth of the observation matrix a.
-c if necessary, interchange the variables x and y, in order to obtain
-c a minimal bandwidth.
- iband1 = kx*(ny-ky1)+ky
- l = ky*(nx-kx1)+kx
- if(iband1.le.l) go to 130
- iband1 = l
- ichang = -ichang
- do 60 i=1,m
- store = x(i)
- x(i) = y(i)
- y(i) = store
- 60 continue
- store = x0
- x0 = y0
- y0 = store
- store = x1
- x1 = y1
- y1 = store
- n = min0(nx,ny)
- do 70 i=1,n
- store = tx(i)
- tx(i) = ty(i)
- ty(i) = store
- 70 continue
- n1 = n+1
- if (nx.lt.ny) go to 80
- if (nx.eq.ny) go to 120
- go to 100
- 80 do 90 i=n1,ny
- tx(i) = ty(i)
- 90 continue
- go to 120
- 100 do 110 i=n1,nx
- ty(i) = tx(i)
- 110 continue
- 120 l = nx
- nx = ny
- ny = l
- l = nxe
- nxe = nye
- nye = l
- l = nxx
- nxx = nyy
- nyy = l
- l = kx
- kx = ky
- ky = l
- kx1 = kx+1
- ky1 = ky+1
- 130 iband = iband1+1
-c arrange the data points according to the panel they belong to.
- call fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg)
-c find ncof, the number of b-spline coefficients.
- nk1x = nx-kx1
- nk1y = ny-ky1
- ncof = nk1x*nk1y
-c initialize the observation matrix a.
- do 140 i=1,ncof
- f(i) = 0.
- do 140 j=1,iband
- a(i,j) = 0.
- 140 continue
-c initialize the sum of squared residuals.
- fp = 0.
-c fetch the data points in the new order. main loop for the
-c different panels.
- do 250 num=1,nreg
-c fix certain constants for the current panel; jrot records the column
-c number of the first non-zero element in a row of the observation
-c matrix according to a data point of the panel.
- num1 = num-1
- lx = num1/nyy
- l1 = lx+kx1
- ly = num1-lx*nyy
- l2 = ly+ky1
- jrot = lx*nk1y+ly
-c test whether there are still data points in the panel.
- in = index(num)
- 150 if(in.eq.0) go to 250
-c fetch a new data point.
- wi = w(in)
- zi = z(in)*wi
-c evaluate for the x-direction, the (kx+1) non-zero b-splines at x(in).
- call fpbspl(tx,nx,kx,x(in),l1,hx)
-c evaluate for the y-direction, the (ky+1) non-zero b-splines at y(in).
- call fpbspl(ty,ny,ky,y(in),l2,hy)
-c store the value of these b-splines in spx and spy respectively.
- do 160 i=1,kx1
- spx(in,i) = hx(i)
- 160 continue
- do 170 i=1,ky1
- spy(in,i) = hy(i)
- 170 continue
-c initialize the new row of observation matrix.
- do 180 i=1,iband
- h(i) = 0.
- 180 continue
-c calculate the non-zero elements of the new row by making the cross
-c products of the non-zero b-splines in x- and y-direction.
- i1 = 0
- do 200 i=1,kx1
- hxi = hx(i)
- j1 = i1
- do 190 j=1,ky1
- j1 = j1+1
- h(j1) = hxi*hy(j)*wi
- 190 continue
- i1 = i1+nk1y
- 200 continue
-c rotate the row into triangle by givens transformations .
- irot = jrot
- do 220 i=1,iband
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 220
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(irot,1),cos,sin)
-c apply that transformation to the right hand side.
- call fprota(cos,sin,zi,f(irot))
- if(i.eq.iband) go to 230
-c apply that transformation to the left hand side.
- i2 = 1
- i3 = i+1
- do 210 j=i3,iband
- i2 = i2+1
- call fprota(cos,sin,h(j),a(irot,i2))
- 210 continue
- 220 continue
-c add the contribution of the row to the sum of squares of residual
-c right hand sides.
- 230 fp = fp+zi**2
-c find the number of the next data point in the panel.
- 240 in = nummer(in)
- go to 150
- 250 continue
-c find dmax, the maximum value for the diagonal elements in the reduced
-c triangle.
- dmax = 0.
- do 260 i=1,ncof
- if(a(i,1).le.dmax) go to 260
- dmax = a(i,1)
- 260 continue
-c check whether the observation matrix is rank deficient.
- sigma = eps*dmax
- do 270 i=1,ncof
- if(a(i,1).le.sigma) go to 280
- 270 continue
-c backward substitution in case of full rank.
- call fpback(a,f,ncof,iband,c,nc)
- rank = ncof
- do 275 i=1,ncof
- q(i,1) = a(i,1)/dmax
- 275 continue
- go to 300
-c in case of rank deficiency, find the minimum norm solution.
-c check whether there is sufficient working space
- 280 lwest = ncof*iband+ncof+iband
- if(lwrk.lt.lwest) go to 780
- do 290 i=1,ncof
- ff(i) = f(i)
- do 290 j=1,iband
- q(i,j) = a(i,j)
- 290 continue
- lf =1
- lh = lf+ncof
- la = lh+iband
- call fprank(q,ff,ncof,iband,nc,sigma,c,sq,rank,wrk(la),
- * wrk(lf),wrk(lh))
- do 295 i=1,ncof
- q(i,1) = q(i,1)/dmax
- 295 continue
-c add to the sum of squared residuals, the contribution of reducing
-c the rank.
- fp = fp+sq
- 300 if(ier.eq.(-2)) fp0 = fp
-c test whether the least-squares spline is an acceptable solution.
- if(iopt.lt.0) go to 820
- fpms = fp-s
- if(abs(fpms).le.acc) then
- if (fp.le.0) go to 815
- go to 820
- endif
-c test whether we can accept the choice of knots.
- if(fpms.lt.0.) go to 430
-c test whether we cannot further increase the number of knots.
- if(ncof.gt.m) go to 790
- ier = 0
-c search where to add a new knot.
-c find for each interval the sum of squared residuals fpint for the
-c data points having the coordinate belonging to that knot interval.
-c calculate also coord which is the same sum, weighted by the position
-c of the data points considered.
- 310 do 320 i=1,nrint
- fpint(i) = 0.
- coord(i) = 0.
- 320 continue
- do 360 num=1,nreg
- num1 = num-1
- lx = num1/nyy
- l1 = lx+1
- ly = num1-lx*nyy
- l2 = ly+1+nxx
- jrot = lx*nk1y+ly
- in = index(num)
- 330 if(in.eq.0) go to 360
- store = 0.
- i1 = jrot
- do 350 i=1,kx1
- hxi = spx(in,i)
- j1 = i1
- do 340 j=1,ky1
- j1 = j1+1
- store = store+hxi*spy(in,j)*c(j1)
- 340 continue
- i1 = i1+nk1y
- 350 continue
- store = (w(in)*(z(in)-store))**2
- fpint(l1) = fpint(l1)+store
- coord(l1) = coord(l1)+store*x(in)
- fpint(l2) = fpint(l2)+store
- coord(l2) = coord(l2)+store*y(in)
- in = nummer(in)
- go to 330
- 360 continue
-c find the interval for which fpint is maximal on the condition that
-c there still can be added a knot.
- 370 l = 0
- fpmax = 0.
- l1 = 1
- l2 = nrint
- if(nx.eq.nxe) l1 = nxx+1
- if(ny.eq.nye) l2 = nxx
- if(l1.gt.l2) go to 810
- do 380 i=l1,l2
- if(fpmax.ge.fpint(i)) go to 380
- l = i
- fpmax = fpint(i)
- 380 continue
-c test whether we cannot further increase the number of knots.
- if(l.eq.0) go to 785
-c calculate the position of the new knot.
- arg = coord(l)/fpint(l)
-c test in what direction the new knot is going to be added.
- if(l.gt.nxx) go to 400
-c addition in the x-direction.
- jxy = l+kx1
- fpint(l) = 0.
- fac1 = tx(jxy)-arg
- fac2 = arg-tx(jxy-1)
- if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370
- j = nx
- do 390 i=jxy,nx
- tx(j+1) = tx(j)
- j = j-1
- 390 continue
- tx(jxy) = arg
- nx = nx+1
- go to 420
-c addition in the y-direction.
- 400 jxy = l+ky1-nxx
- fpint(l) = 0.
- fac1 = ty(jxy)-arg
- fac2 = arg-ty(jxy-1)
- if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370
- j = ny
- do 410 i=jxy,ny
- ty(j+1) = ty(j)
- j = j-1
- 410 continue
- ty(jxy) = arg
- ny = ny+1
-c restart the computations with the new set of knots.
- 420 continue
-c test whether the least-squares polynomial is a solution of our
-c approximation problem.
- 430 if(ier.eq.(-2)) go to 830
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 2: determination of the smoothing spline sp(x,y) c
-c ***************************************************** c
-c we have determined the number of knots and their position. we now c
-c compute the b-spline coefficients of the smoothing spline sp(x,y). c
-c the observation matrix a is extended by the rows of a matrix, c
-c expressing that sp(x,y) must be a polynomial of degree kx in x and c
-c ky in y. the corresponding weights of these additional rows are set c
-c to 1./p. iteratively we than have to determine the value of p c
-c such that f(p)=sum((w(i)*(z(i)-sp(x(i),y(i))))**2) be = s. c
-c we already know that the least-squares polynomial corresponds to c
-c p=0 and that the least-squares spline corresponds to p=infinity. c
-c the iteration process which is proposed here makes use of rational c
-c interpolation. since f(p) is a convex and strictly decreasing c
-c function of p, it can be approximated by a rational function r(p)= c
-c (u*p+v)/(p+w). three values of p(p1,p2,p3) with corresponding values c
-c of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the c
-c new value of p such that r(p)=s. convergence is guaranteed by taking c
-c f1 > 0 and f3 < 0. c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- kx2 = kx1+1
-c test whether there are interior knots in the x-direction.
- if(nk1x.eq.kx1) go to 440
-c evaluate the discotinuity jumps of the kx-th order derivative of
-c the b-splines at the knots tx(l),l=kx+2,...,nx-kx-1.
- call fpdisc(tx,nx,kx2,bx,nmax)
- 440 ky2 = ky1 + 1
-c test whether there are interior knots in the y-direction.
- if(nk1y.eq.ky1) go to 450
-c evaluate the discontinuity jumps of the ky-th order derivative of
-c the b-splines at the knots ty(l),l=ky+2,...,ny-ky-1.
- call fpdisc(ty,ny,ky2,by,nmax)
-c initial value for p.
- 450 p1 = 0.
- f1 = fp0-s
- p3 = -one
- f3 = fpms
- p = 0.
- do 460 i=1,ncof
- p = p+a(i,1)
- 460 continue
- rn = ncof
- p = rn/p
-c find the bandwidth of the extended observation matrix.
- iband3 = kx1*nk1y
- iband4 = iband3 +1
- ich1 = 0
- ich3 = 0
-c iteration process to find the root of f(p)=s.
- do 770 iter=1,maxit
- pinv = one/p
-c store the triangularized observation matrix into q.
- do 480 i=1,ncof
- ff(i) = f(i)
- do 470 j=1,iband
- q(i,j) = a(i,j)
- 470 continue
- ibb = iband+1
- do 480 j=ibb,iband4
- q(i,j) = 0.
- 480 continue
- if(nk1y.eq.ky1) go to 560
-c extend the observation matrix with the rows of a matrix, expressing
-c that for x=cst. sp(x,y) must be a polynomial in y of degree ky.
- do 550 i=ky2,nk1y
- ii = i-ky1
- do 550 j=1,nk1x
-c initialize the new row.
- do 490 l=1,iband
- h(l) = 0.
- 490 continue
-c fill in the non-zero elements of the row. jrot records the column
-c number of the first non-zero element in the row.
- do 500 l=1,ky2
- h(l) = by(ii,l)*pinv
- 500 continue
- zi = 0.
- jrot = (j-1)*nk1y+ii
-c rotate the new row into triangle by givens transformations without
-c square roots.
- do 540 irot=jrot,ncof
- piv = h(1)
- i2 = min0(iband1,ncof-irot)
- if(piv.eq.0.) then
- if (i2.le.0) go to 550
- go to 520
- endif
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,q(irot,1),cos,sin)
-c apply that givens transformation to the right hand side.
- call fprota(cos,sin,zi,ff(irot))
- if(i2.eq.0) go to 550
-c apply that givens transformation to the left hand side.
- do 510 l=1,i2
- l1 = l+1
- call fprota(cos,sin,h(l1),q(irot,l1))
- 510 continue
- 520 do 530 l=1,i2
- h(l) = h(l+1)
- 530 continue
- h(i2+1) = 0.
- 540 continue
- 550 continue
- 560 if(nk1x.eq.kx1) go to 640
-c extend the observation matrix with the rows of a matrix expressing
-c that for y=cst. sp(x,y) must be a polynomial in x of degree kx.
- do 630 i=kx2,nk1x
- ii = i-kx1
- do 630 j=1,nk1y
-c initialize the new row
- do 570 l=1,iband4
- h(l) = 0.
- 570 continue
-c fill in the non-zero elements of the row. jrot records the column
-c number of the first non-zero element in the row.
- j1 = 1
- do 580 l=1,kx2
- h(j1) = bx(ii,l)*pinv
- j1 = j1+nk1y
- 580 continue
- zi = 0.
- jrot = (i-kx2)*nk1y+j
-c rotate the new row into triangle by givens transformations .
- do 620 irot=jrot,ncof
- piv = h(1)
- i2 = min0(iband3,ncof-irot)
- if(piv.eq.0.) then
- if (i2.le.0) go to 630
- go to 600
- endif
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,q(irot,1),cos,sin)
-c apply that givens transformation to the right hand side.
- call fprota(cos,sin,zi,ff(irot))
- if(i2.eq.0) go to 630
-c apply that givens transformation to the left hand side.
- do 590 l=1,i2
- l1 = l+1
- call fprota(cos,sin,h(l1),q(irot,l1))
- 590 continue
- 600 do 610 l=1,i2
- h(l) = h(l+1)
- 610 continue
- h(i2+1) = 0.
- 620 continue
- 630 continue
-c find dmax, the maximum value for the diagonal elements in the
-c reduced triangle.
- 640 dmax = 0.
- do 650 i=1,ncof
- if(q(i,1).le.dmax) go to 650
- dmax = q(i,1)
- 650 continue
-c check whether the matrix is rank deficient.
- sigma = eps*dmax
- do 660 i=1,ncof
- if(q(i,1).le.sigma) go to 670
- 660 continue
-c backward substitution in case of full rank.
- call fpback(q,ff,ncof,iband4,c,nc)
- rank = ncof
- go to 675
-c in case of rank deficiency, find the minimum norm solution.
- 670 lwest = ncof*iband4+ncof+iband4
- if(lwrk.lt.lwest) go to 780
- lf = 1
- lh = lf+ncof
- la = lh+iband4
- call fprank(q,ff,ncof,iband4,nc,sigma,c,sq,rank,wrk(la),
- * wrk(lf),wrk(lh))
- 675 do 680 i=1,ncof
- q(i,1) = q(i,1)/dmax
- 680 continue
-c compute f(p).
- fp = 0.
- do 720 num = 1,nreg
- num1 = num-1
- lx = num1/nyy
- ly = num1-lx*nyy
- jrot = lx*nk1y+ly
- in = index(num)
- 690 if(in.eq.0) go to 720
- store = 0.
- i1 = jrot
- do 710 i=1,kx1
- hxi = spx(in,i)
- j1 = i1
- do 700 j=1,ky1
- j1 = j1+1
- store = store+hxi*spy(in,j)*c(j1)
- 700 continue
- i1 = i1+nk1y
- 710 continue
- fp = fp+(w(in)*(z(in)-store))**2
- in = nummer(in)
- go to 690
- 720 continue
-c test whether the approximation sp(x,y) is an acceptable solution.
- fpms = fp-s
- if(abs(fpms).le.acc) go to 820
-c test whether the maximum allowable number of iterations has been
-c reached.
- if(iter.eq.maxit) go to 795
-c carry out one more step of the iteration process.
- p2 = p
- f2 = fpms
- if(ich3.ne.0) go to 740
- if((f2-f3).gt.acc) go to 730
-c our initial choice of p is too large.
- p3 = p2
- f3 = f2
- p = p*con4
- if(p.le.p1) p = p1*con9 + p2*con1
- go to 770
- 730 if(f2.lt.0.) ich3 = 1
- 740 if(ich1.ne.0) go to 760
- if((f1-f2).gt.acc) go to 750
-c our initial choice of p is too small
- p1 = p2
- f1 = f2
- p = p/con4
- if(p3.lt.0.) go to 770
- if(p.ge.p3) p = p2*con1 + p3*con9
- go to 770
- 750 if(f2.gt.0.) ich1 = 1
-c test whether the iteration process proceeds as theoretically
-c expected.
- 760 if(f2.ge.f1 .or. f2.le.f3) go to 800
-c find the new value of p.
- p = fprati(p1,f1,p2,f2,p3,f3)
- 770 continue
-c error codes and messages.
- 780 ier = lwest
- go to 830
- 785 ier = 5
- go to 830
- 790 ier = 4
- go to 830
- 795 ier = 3
- go to 830
- 800 ier = 2
- go to 830
- 810 ier = 1
- go to 830
- 815 ier = -1
- fp = 0.
- 820 if(ncof.ne.rank) ier = -rank
-c test whether x and y are in the original order.
- 830 if(ichang.lt.0) go to 930
-c if not, interchange x and y once more.
- l1 = 1
- do 840 i=1,nk1x
- l2 = i
- do 840 j=1,nk1y
- f(l2) = c(l1)
- l1 = l1+1
- l2 = l2+nk1x
- 840 continue
- do 850 i=1,ncof
- c(i) = f(i)
- 850 continue
- do 860 i=1,m
- store = x(i)
- x(i) = y(i)
- y(i) = store
- 860 continue
- n = min0(nx,ny)
- do 870 i=1,n
- store = tx(i)
- tx(i) = ty(i)
- ty(i) = store
- 870 continue
- n1 = n+1
- if (nx.lt.ny) go to 880
- if (nx.eq.ny) go to 920
- go to 900
- 880 do 890 i=n1,ny
- tx(i) = ty(i)
- 890 continue
- go to 920
- 900 do 910 i=n1,nx
- ty(i) = tx(i)
- 910 continue
- 920 l = nx
- nx = ny
- ny = l
- 930 if(iopt.lt.0) go to 940
- nx0 = nx
- ny0 = ny
- 940 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fpsysy.f
===================================================================
--- branches/Interpolate1D/fitpack/fpsysy.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fpsysy.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,56 +0,0 @@
- subroutine fpsysy(a,n,g)
-c subroutine fpsysy solves a linear n x n symmetric system
-c (a) * (b) = (g)
-c on input, vector g contains the right hand side ; on output it will
-c contain the solution (b).
-c ..
-c ..scalar arguments..
- integer n
-c ..array arguments..
- real*8 a(6,6),g(6)
-c ..local scalars..
- real*8 fac
- integer i,i1,j,k
-c ..
- g(1) = g(1)/a(1,1)
- if(n.eq.1) return
-c decomposition of the symmetric matrix (a) = (l) * (d) *(l)'
-c with (l) a unit lower triangular matrix and (d) a diagonal
-c matrix
- do 10 k=2,n
- a(k,1) = a(k,1)/a(1,1)
- 10 continue
- do 40 i=2,n
- i1 = i-1
- do 30 k=i,n
- fac = a(k,i)
- do 20 j=1,i1
- fac = fac-a(j,j)*a(k,j)*a(i,j)
- 20 continue
- a(k,i) = fac
- if(k.gt.i) a(k,i) = fac/a(i,i)
- 30 continue
- 40 continue
-c solve the system (l)*(d)*(l)'*(b) = (g).
-c first step : solve (l)*(d)*(c) = (g).
- do 60 i=2,n
- i1 = i-1
- fac = g(i)
- do 50 j=1,i1
- fac = fac-g(j)*a(j,j)*a(i,j)
- 50 continue
- g(i) = fac/a(i,i)
- 60 continue
-c second step : solve (l)'*(b) = (c)
- i = n
- do 80 j=2,n
- i1 = i
- i = i-1
- fac = g(i)
- do 70 k=i1,n
- fac = fac-g(k)*a(k,i)
- 70 continue
- g(i) = fac
- 80 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fptrnp.f
===================================================================
--- branches/Interpolate1D/fitpack/fptrnp.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fptrnp.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,106 +0,0 @@
- subroutine fptrnp(m,mm,idim,n,nr,sp,p,b,z,a,q,right)
-c subroutine fptrnp reduces the (m+n-7) x (n-4) matrix a to upper
-c triangular form and applies the same givens transformations to
-c the (m) x (mm) x (idim) matrix z to obtain the (n-4) x (mm) x
-c (idim) matrix q
-c ..
-c ..scalar arguments..
- real*8 p
- integer m,mm,idim,n
-c ..array arguments..
- real*8 sp(m,4),b(n,5),z(m*mm*idim),a(n,5),q((n-4)*mm*idim),
- * right(mm*idim)
- integer nr(m)
-c ..local scalars..
- real*8 cos,pinv,piv,sin,one
- integer i,iband,irot,it,ii,i2,i3,j,jj,l,mid,nmd,m2,m3,
- * nrold,n4,number,n1
-c ..local arrays..
- real*8 h(7)
-c ..subroutine references..
-c fpgivs,fprota
-c ..
- one = 1
- if(p.gt.0.) pinv = one/p
- n4 = n-4
- mid = mm*idim
- m2 = m*mm
- m3 = n4*mm
-c reduce the matrix (a) to upper triangular form (r) using givens
-c rotations. apply the same transformations to the rows of matrix z
-c to obtain the mm x (n-4) matrix g.
-c store matrix (r) into (a) and g into q.
-c initialization.
- nmd = n4*mid
- do 50 i=1,nmd
- q(i) = 0.
- 50 continue
- do 100 i=1,n4
- do 100 j=1,5
- a(i,j) = 0.
- 100 continue
- nrold = 0
-c iband denotes the bandwidth of the matrices (a) and (r).
- iband = 4
- do 750 it=1,m
- number = nr(it)
- 150 if(nrold.eq.number) go to 300
- if(p.le.0.) go to 700
- iband = 5
-c fetch a new row of matrix (b).
- n1 = nrold+1
- do 200 j=1,5
- h(j) = b(n1,j)*pinv
- 200 continue
-c find the appropriate column of q.
- do 250 j=1,mid
- right(j) = 0.
- 250 continue
- irot = nrold
- go to 450
-c fetch a new row of matrix (sp).
- 300 h(iband) = 0.
- do 350 j=1,4
- h(j) = sp(it,j)
- 350 continue
-c find the appropriate column of q.
- j = 0
- do 400 ii=1,idim
- l = (ii-1)*m2+(it-1)*mm
- do 400 jj=1,mm
- j = j+1
- l = l+1
- right(j) = z(l)
- 400 continue
- irot = number
-c rotate the new row of matrix (a) into triangle.
- 450 do 600 i=1,iband
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 600
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(irot,1),cos,sin)
-c apply that transformation to the rows of matrix q.
- j = 0
- do 500 ii=1,idim
- l = (ii-1)*m3+irot
- do 500 jj=1,mm
- j = j+1
- call fprota(cos,sin,right(j),q(l))
- l = l+n4
- 500 continue
-c apply that transformation to the columns of (a).
- if(i.eq.iband) go to 650
- i2 = 1
- i3 = i+1
- do 550 j=i3,iband
- i2 = i2+1
- call fprota(cos,sin,h(j),a(irot,i2))
- 550 continue
- 600 continue
- 650 if(nrold.eq.number) go to 750
- 700 nrold = nrold+1
- go to 150
- 750 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/fptrpe.f
===================================================================
--- branches/Interpolate1D/fitpack/fptrpe.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/fptrpe.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,212 +0,0 @@
- subroutine fptrpe(m,mm,idim,n,nr,sp,p,b,z,a,aa,q,right)
-c subroutine fptrpe reduces the (m+n-7) x (n-7) cyclic bandmatrix a
-c to upper triangular form and applies the same givens transformations
-c to the (m) x (mm) x (idim) matrix z to obtain the (n-7) x (mm) x
-c (idim) matrix q.
-c ..
-c ..scalar arguments..
- real*8 p
- integer m,mm,idim,n
-c ..array arguments..
- real*8 sp(m,4),b(n,5),z(m*mm*idim),a(n,5),aa(n,4),q((n-7)*mm*idim)
- *,
- * right(mm*idim)
- integer nr(m)
-c ..local scalars..
- real*8 co,pinv,piv,si,one
- integer i,iband,irot,it,ii,i2,i3,j,jj,l,mid,nmd,m2,m3,
- * nrold,n4,number,n1,n7,n11,m1
-c ..local arrays..
- real*8 h(5),h1(5),h2(4)
-c ..subroutine references..
-c fpgivs,fprota
-c ..
- one = 1
- if(p.gt.0.) pinv = one/p
- n4 = n-4
- n7 = n-7
- n11 = n-11
- mid = mm*idim
- m2 = m*mm
- m3 = n7*mm
- m1 = m-1
-c we determine the matrix (a) and then we reduce her to
-c upper triangular form (r) using givens rotations.
-c we apply the same transformations to the rows of matrix
-c z to obtain the (mm) x (n-7) matrix g.
-c we store matrix (r) into a and aa, g into q.
-c the n7 x n7 upper triangular matrix (r) has the form
-c | a1 ' |
-c (r) = | ' a2 |
-c | 0 ' |
-c with (a2) a n7 x 4 matrix and (a1) a n11 x n11 upper
-c triangular matrix of bandwidth 5.
-c initialization.
- nmd = n7*mid
- do 50 i=1,nmd
- q(i) = 0.
- 50 continue
- do 100 i=1,n4
- a(i,5) = 0.
- do 100 j=1,4
- a(i,j) = 0.
- aa(i,j) = 0.
- 100 continue
- jper = 0
- nrold = 0
- do 760 it=1,m1
- number = nr(it)
- 120 if(nrold.eq.number) go to 180
- if(p.le.0.) go to 740
-c fetch a new row of matrix (b).
- n1 = nrold+1
- do 140 j=1,5
- h(j) = b(n1,j)*pinv
- 140 continue
-c find the appropiate row of q.
- do 160 j=1,mid
- right(j) = 0.
- 160 continue
- go to 240
-c fetch a new row of matrix (sp)
- 180 h(5) = 0.
- do 200 j=1,4
- h(j) = sp(it,j)
- 200 continue
-c find the appropiate row of q.
- j = 0
- do 220 ii=1,idim
- l = (ii-1)*m2+(it-1)*mm
- do 220 jj=1,mm
- j = j+1
- l = l+1
- right(j) = z(l)
- 220 continue
-c test whether there are non-zero values in the new row of (a)
-c corresponding to the b-splines n(j,*),j=n7+1,...,n4.
- 240 if(nrold.lt.n11) go to 640
- if(jper.ne.0) go to 320
-c initialize the matrix (aa).
- jk = n11+1
- do 300 i=1,4
- ik = jk
- do 260 j=1,5
- if(ik.le.0) go to 280
- aa(ik,i) = a(ik,j)
- ik = ik-1
- 260 continue
- 280 jk = jk+1
- 300 continue
- jper = 1
-c if one of the non-zero elements of the new row corresponds to one of
-c the b-splines n(j;*),j=n7+1,...,n4,we take account of the periodicity
-c conditions for setting up this row of (a).
- 320 do 340 i=1,4
- h1(i) = 0.
- h2(i) = 0.
- 340 continue
- h1(5) = 0.
- j = nrold-n11
- do 420 i=1,5
- j = j+1
- l0 = j
- 360 l1 = l0-4
- if(l1.le.0) go to 400
- if(l1.le.n11) go to 380
- l0 = l1-n11
- go to 360
- 380 h1(l1) = h(i)
- go to 420
- 400 h2(l0) = h2(l0) + h(i)
- 420 continue
-c rotate the new row of (a) into triangle.
- if(n11.le.0) go to 560
-c rotations with the rows 1,2,...,n11 of (a).
- do 540 irot=1,n11
- piv = h1(1)
- i2 = min0(n11-irot,4)
- if(piv.eq.0.) go to 500
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(irot,1),co,si)
-c apply that transformation to the columns of matrix q.
- j = 0
- do 440 ii=1,idim
- l = (ii-1)*m3+irot
- do 440 jj=1,mm
- j = j+1
- call fprota(co,si,right(j),q(l))
- l = l+n7
- 440 continue
-c apply that transformation to the rows of (a) with respect to aa.
- do 460 i=1,4
- call fprota(co,si,h2(i),aa(irot,i))
- 460 continue
-c apply that transformation to the rows of (a) with respect to a.
- if(i2.eq.0) go to 560
- do 480 i=1,i2
- i1 = i+1
- call fprota(co,si,h1(i1),a(irot,i1))
- 480 continue
- 500 do 520 i=1,i2
- h1(i) = h1(i+1)
- 520 continue
- h1(i2+1) = 0.
- 540 continue
-c rotations with the rows n11+1,...,n7 of a.
- 560 do 620 irot=1,4
- ij = n11+irot
- if(ij.le.0) go to 620
- piv = h2(irot)
- if(piv.eq.0.) go to 620
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,aa(ij,irot),co,si)
-c apply that transformation to the columns of matrix q.
- j = 0
- do 580 ii=1,idim
- l = (ii-1)*m3+ij
- do 580 jj=1,mm
- j = j+1
- call fprota(co,si,right(j),q(l))
- l = l+n7
- 580 continue
- if(irot.eq.4) go to 620
-c apply that transformation to the rows of (a) with respect to aa.
- j1 = irot+1
- do 600 i=j1,4
- call fprota(co,si,h2(i),aa(ij,i))
- 600 continue
- 620 continue
- go to 720
-c rotation into triangle of the new row of (a), in case the elements
-c corresponding to the b-splines n(j;*),j=n7+1,...,n4 are all zero.
- 640 irot =nrold
- do 700 i=1,5
- irot = irot+1
- piv = h(i)
- if(piv.eq.0.) go to 700
-c calculate the parameters of the givens transformation.
- call fpgivs(piv,a(irot,1),co,si)
-c apply that transformation to the columns of matrix g.
- j = 0
- do 660 ii=1,idim
- l = (ii-1)*m3+irot
- do 660 jj=1,mm
- j = j+1
- call fprota(co,si,right(j),q(l))
- l = l+n7
- 660 continue
-c apply that transformation to the rows of (a).
- if(i.eq.5) go to 700
- i2 = 1
- i3 = i+1
- do 680 j=i3,5
- i2 = i2+1
- call fprota(co,si,h(j),a(irot,i2))
- 680 continue
- 700 continue
- 720 if(nrold.eq.number) go to 760
- 740 nrold = nrold+1
- go to 120
- 760 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/insert.f
===================================================================
--- branches/Interpolate1D/fitpack/insert.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/insert.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,102 +0,0 @@
- subroutine insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier)
-c subroutine insert inserts a new knot x into a spline function s(x)
-c of degree k and calculates the b-spline representation of s(x) with
-c respect to the new set of knots. in addition, if iopt.ne.0, s(x)
-c will be considered as a periodic spline with period per=t(n-k)-t(k+1)
-c satisfying the boundary constraints
-c t(i+n-2*k-1) = t(i)+per ,i=1,2,...,2*k+1
-c c(i+n-2*k-1) = c(i) ,i=1,2,...,k
-c in that case, the knots and b-spline coefficients returned will also
-c satisfy these boundary constraints, i.e.
-c tt(i+nn-2*k-1) = tt(i)+per ,i=1,2,...,2*k+1
-c cc(i+nn-2*k-1) = cc(i) ,i=1,2,...,k
-c
-c calling sequence:
-c call insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier)
-c
-c input parameters:
-c iopt : integer flag, specifying whether (iopt.ne.0) or not (iopt=0)
-c the given spline must be considered as being periodic.
-c t : array,length nest, which contains the position of the knots.
-c n : integer, giving the total number of knots of s(x).
-c c : array,length nest, which contains the b-spline coefficients.
-c k : integer, giving the degree of s(x).
-c x : real, which gives the location of the knot to be inserted.
-c nest : integer specifying the dimension of the arrays t,c,tt and cc
-c nest > n.
-c
-c output parameters:
-c tt : array,length nest, which contains the position of the knots
-c after insertion.
-c nn : integer, giving the total number of knots after insertion
-c cc : array,length nest, which contains the b-spline coefficients
-c of s(x) with respect to the new set of knots.
-c ier : error flag
-c ier = 0 : normal return
-c ier =10 : invalid input data (see restrictions)
-c
-c restrictions:
-c nest > n
-c t(k+1) <= x <= t(n-k)
-c in case of a periodic spline (iopt.ne.0) there must be
-c either at least k interior knots t(j) satisfying t(k+1)<t(j)<=x
-c or at least k interior knots t(j) satisfying x<=t(j)<t(n-k)
-c
-c other subroutines required: fpinst.
-c
-c further comments:
-c subroutine insert may be called as follows
-c call insert(iopt,t,n,c,k,x,t,n,c,nest,ier)
-c in which case the new representation will simply replace the old one
-c
-c references :
-c boehm w : inserting new knots into b-spline curves. computer aided
-c design 12 (1980) 199-201.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : february 2007 (second interval search added)
-c
-c ..scalar arguments..
- integer iopt,n,k,nn,nest,ier
- real*8 x
-c ..array arguments..
- real*8 t(nest),c(nest),tt(nest),cc(nest)
-c ..local scalars..
- integer kk,k1,l,nk
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- if(nest.le.n) go to 40
- k1 = k+1
- nk = n-k
- if(x.lt.t(k1) .or. x.gt.t(nk)) go to 40
-c search for knot interval t(l) <= x < t(l+1).
- l = k1
- 10 if(x.lt.t(l+1)) go to 20
- l = l+1
- if(l.eq.nk) go to 14
- go to 10
-c if no interval found above, then reverse the search and
-c look for knot interval t(l) < x <= t(l+1).
- 14 l = nk-1
- 16 if(x.gt.t(l)) go to 20
- l = l-1
- if(l.eq.k) go to 40
- go to 16
- 20 if(t(l).ge.t(l+1)) go to 40
- if(iopt.eq.0) go to 30
- kk = 2*k
- if(l.le.kk .and. l.ge.(n-kk)) go to 40
- 30 ier = 0
-c insert the new knot.
- call fpinst(iopt,t,n,c,k,x,l,tt,nn,cc,nest)
- 40 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/parcur.f
===================================================================
--- branches/Interpolate1D/fitpack/parcur.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/parcur.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,334 +0,0 @@
- subroutine parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t,
- * nc,c,fp,wrk,lwrk,iwrk,ier)
-c given the ordered set of m points x(i) in the idim-dimensional space
-c and given also a corresponding set of strictly increasing values u(i)
-c and the set of positive numbers w(i),i=1,2,...,m, subroutine parcur
-c determines a smooth approximating spline curve s(u), i.e.
-c x1 = s1(u)
-c x2 = s2(u) ub <= u <= ue
-c .........
-c xidim = sidim(u)
-c with sj(u),j=1,2,...,idim spline functions of degree k with common
-c knots t(j),j=1,2,...,n.
-c if ipar=1 the values ub,ue and u(i),i=1,2,...,m must be supplied by
-c the user. if ipar=0 these values are chosen automatically by parcur
-c as v(1) = 0
-c v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m
-c u(i) = v(i)/v(m) ,i=1,2,...,m
-c ub = u(1) = 0, ue = u(m) = 1.
-c if iopt=-1 parcur calculates the weighted least-squares spline curve
-c according to a given set of knots.
-c if iopt>=0 the number of knots of the splines sj(u) and the position
-c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
-c ness of s(u) is then achieved by minimalizing the discontinuity
-c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,...,
-c n-k-1. the amount of smoothness is determined by the condition that
-c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non-
-c negative constant, called the smoothing factor.
-c the fit s(u) is given in the b-spline representation and can be
-c evaluated by means of subroutine curev.
-c
-c calling sequence:
-c call parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t,nc,c,
-c * fp,wrk,lwrk,iwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares spline curve (iopt=-1) or a smoothing spline
-c curve (iopt=0 or 1) must be determined.if iopt=0 the routine
-c will start with an initial set of knots t(i)=ub,t(i+k+1)=ue,
-c i=1,2,...,k+1. if iopt=1 the routine will continue with the
-c knots found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c ipar : integer flag. on entry ipar must specify whether (ipar=1)
-c the user will supply the parameter values u(i),ub and ue
-c or whether (ipar=0) these values are to be calculated by
-c parcur. unchanged on exit.
-c idim : integer. on entry idim must specify the dimension of the
-c curve. 0 < idim < 11.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m > k. unchanged on exit.
-c u : real array of dimension at least (m). in case ipar=1,before
-c entry, u(i) must be set to the i-th value of the parameter
-c variable u for i=1,2,...,m. these values must then be
-c supplied in strictly ascending order and will be unchanged
-c on exit. in case ipar=0, on exit,array u will contain the
-c values u(i) as determined by parcur.
-c mx : integer. on entry mx must specify the actual dimension of
-c the array x as declared in the calling (sub)program. mx must
-c not be too small (see x). unchanged on exit.
-c x : real array of dimension at least idim*m.
-c before entry, x(idim*(i-1)+j) must contain the j-th coord-
-c inate of the i-th data point for i=1,2,...,m and j=1,2,...,
-c idim. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. unchanged on exit.
-c see also further comments.
-c ub,ue : real values. on entry (in case ipar=1) ub and ue must
-c contain the lower and upper bound for the parameter u.
-c ub <=u(1), ue>= u(m). if ipar = 0 these values will
-c automatically be set to 0 and 1 by parcur.
-c k : integer. on entry k must specify the degree of the splines.
-c 1<=k<=5. it is recommended to use cubic splines (k=3).
-c the user is strongly dissuaded from choosing k even,together
-c with a small s-value. unchanged on exit.
-c s : real.on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments.
-c nest : integer. on entry nest must contain an over-estimate of the
-c total number of knots of the splines returned, to indicate
-c the storage space available to the routine. nest >=2*k+2.
-c in most practical situation nest=m/2 will be sufficient.
-c always large enough is nest=m+k+1, the number of knots
-c needed for interpolation (s=0). unchanged on exit.
-c n : integer.
-c unless ier = 10 (in case iopt >=0), n will contain the
-c total number of knots of the smoothing spline curve returned
-c if the computation mode iopt=1 is used this value of n
-c should be left unchanged between subsequent calls.
-c in case iopt=-1, the value of n must be specified on entry.
-c t : real array of dimension at least (nest).
-c on succesful exit, this array will contain the knots of the
-c spline curve,i.e. the position of the interior knots t(k+2),
-c t(k+3),..,t(n-k-1) as well as the position of the additional
-c t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for
-c the b-spline representation.
-c if the computation mode iopt=1 is used, the values of t(1),
-c t(2),...,t(n) should be left unchanged between subsequent
-c calls. if the computation mode iopt=-1 is used, the values
-c t(k+2),...,t(n-k-1) must be supplied by the user, before
-c entry. see also the restrictions (ier=10).
-c nc : integer. on entry nc must specify the actual dimension of
-c the array c as declared in the calling (sub)program. nc
-c must not be too small (see c). unchanged on exit.
-c c : real array of dimension at least (nest*idim).
-c on succesful exit, this array will contain the coefficients
-c in the b-spline representation of the spline curve s(u),i.e.
-c the b-spline coefficients of the spline sj(u) will be given
-c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim.
-c fp : real. unless ier = 10, fp contains the weighted sum of
-c squared residuals of the spline curve returned.
-c wrk : real array of dimension at least m*(k+1)+nest*(6+idim+3*k).
-c used as working space. if the computation mode iopt=1 is
-c used, the values wrk(1),...,wrk(n) should be left unchanged
-c between subsequent calls.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program. lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (nest).
-c used as working space. if the computation mode iopt=1 is
-c used,the values iwrk(1),...,iwrk(n) should be left unchanged
-c between subsequent calls.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the curve returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the curve returned is an interpolating
-c spline curve (fp=0).
-c ier=-2 : normal return. the curve returned is the weighted least-
-c squares polynomial curve of degree k.in this extreme case
-c fp gives the upper bound fp0 for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameter nest.
-c probably causes : nest too small. if nest is already
-c large (say nest > m/2), it may also indicate that s is
-c too small
-c the approximation returned is the least-squares spline
-c curve according to the knots t(1),t(2),...,t(n). (n=nest)
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline curve
-c with fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing curve
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m
-c 0<=ipar<=1, 0<idim<=10, lwrk>=(k+1)*m+nest*(6+idim+3*k),
-c nc>=nest*idim
-c if ipar=0: sum j=1,idim (x(idim*i+j)-x(idim*(i-1)+j))**2>0
-c i=1,2,...,m-1.
-c if ipar=1: ub<=u(1)<u(2)<...<u(m)<=ue
-c if iopt=-1: 2*k+2<=n<=min(nest,m+k+1)
-c ub<t(k+2)<t(k+3)<...<t(n-k-1)<ue
-c (ub=0 and ue=1 in case ipar=0)
-c the schoenberg-whitney conditions, i.e. there
-c must be a subset of data points uu(j) such that
-c t(j) < uu(j) < t(j+k+1), j=1,2,...,n-k-1
-c if iopt>=0: s>=0
-c if s=0 : nest >= m+k+1
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the curve will be too smooth and signal will be
-c lost ; if s is too small the curve will pick up too much noise. in
-c the extreme cases the program will return an interpolating curve if
-c s=0 and the least-squares polynomial curve of degree k if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in x(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c polynomial curve and the upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximating curve shows more detail) to obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if parcur is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c curve underlying the data. but, if the computation mode iopt=1 is
-c used, the knots returned may also depend on the s-values at previous
-c calls (if these were smaller). therefore, if after a number of
-c trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c parcur once more with the selected value for s but now with iopt=0.
-c indeed, parcur may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c
-c the form of the approximating curve can strongly be affected by
-c the choice of the parameter values u(i). if there is no physical
-c reason for choosing a particular parameter u, often good results
-c will be obtained with the choice of parcur (in case ipar=0), i.e.
-c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m
-c where
-c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 )
-c other possibilities for q(i) are
-c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2
-c q(i)= sum j=1,idim abs(xj(i)-xj(i-1))
-c q(i)= max j=1,idim abs(xj(i)-xj(i-1))
-c q(i)= 1
-c
-c other subroutines required:
-c fpback,fpbspl,fpchec,fppara,fpdisc,fpgivs,fpknot,fprati,fprota
-c
-c references:
-c dierckx p. : algorithms for smoothing data with periodic and
-c parametric splines, computer graphics and image
-c processing 20 (1982) 171-184.
-c dierckx p. : algorithms for smoothing data with periodic and param-
-c etric splines, report tw55, dept. computer science,
-c k.u.leuven, 1981.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- real*8 ub,ue,s,fp
- integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier
-c ..array arguments..
- real*8 u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk)
- integer iwrk(nest)
-c ..local scalars..
- real*8 tol,dist
- integer i,ia,ib,ifp,ig,iq,iz,i1,i2,j,k1,k2,lwest,maxit,nmin,ncc
-c ..function references
- real*8 sqrt
-c ..
-c we set up the parameters tol and maxit
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 90
- if(ipar.lt.0 .or. ipar.gt.1) go to 90
- if(idim.le.0 .or. idim.gt.10) go to 90
- if(k.le.0 .or. k.gt.5) go to 90
- k1 = k+1
- k2 = k1+1
- nmin = 2*k1
- if(m.lt.k1 .or. nest.lt.nmin) go to 90
- ncc = nest*idim
- if(mx.lt.m*idim .or. nc.lt.ncc) go to 90
- lwest = m*k1+nest*(6+idim+3*k)
- if(lwrk.lt.lwest) go to 90
- if(ipar.ne.0 .or. iopt.gt.0) go to 40
- i1 = 0
- i2 = idim
- u(1) = 0.
- do 20 i=2,m
- dist = 0.
- do 10 j=1,idim
- i1 = i1+1
- i2 = i2+1
- dist = dist+(x(i2)-x(i1))**2
- 10 continue
- u(i) = u(i-1)+sqrt(dist)
- 20 continue
- if(u(m).le.0.) go to 90
- do 30 i=2,m
- u(i) = u(i)/u(m)
- 30 continue
- ub = 0.
- ue = 1.
- u(m) = ue
- 40 if(ub.gt.u(1) .or. ue.lt.u(m) .or. w(1).le.0.) go to 90
- do 50 i=2,m
- if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90
- 50 continue
- if(iopt.ge.0) go to 70
- if(n.lt.nmin .or. n.gt.nest) go to 90
- j = n
- do 60 i=1,k1
- t(i) = ub
- t(j) = ue
- j = j-1
- 60 continue
- call fpchec(u,m,t,n,k,ier)
- if (ier.eq.0) go to 80
- go to 90
- 70 if(s.lt.0.) go to 90
- if(s.eq.0. .and. nest.lt.(m+k1)) go to 90
- ier = 0
-c we partition the working space and determine the spline curve.
- 80 ifp = 1
- iz = ifp+nest
- ia = iz+ncc
- ib = ia+nest*k1
- ig = ib+nest*k2
- iq = ig+nest*k2
- call fppara(iopt,idim,m,u,mx,x,w,ub,ue,k,s,nest,tol,maxit,k1,k2,
- * n,t,ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq),
- * iwrk,ier)
- 90 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/parder.f
===================================================================
--- branches/Interpolate1D/fitpack/parder.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/parder.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,179 +0,0 @@
- subroutine parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,
- * wrk,lwrk,iwrk,kwrk,ier)
-c subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,...
-c ,my the partial derivative ( order nux,nuy) of a bivariate spline
-c s(x,y) of degrees kx and ky, given in the b-spline representation.
-c
-c calling sequence:
-c call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk,
-c * iwrk,kwrk,ier)
-c
-c input parameters:
-c tx : real array, length nx, which contains the position of the
-c knots in the x-direction.
-c nx : integer, giving the total number of knots in the x-direction
-c ty : real array, length ny, which contains the position of the
-c knots in the y-direction.
-c ny : integer, giving the total number of knots in the y-direction
-c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the
-c b-spline coefficients.
-c kx,ky : integer values, giving the degrees of the spline.
-c nux : integer values, specifying the order of the partial
-c nuy derivative. 0<=nux<kx, 0<=nuy<ky.
-c x : real array of dimension (mx).
-c before entry x(i) must be set to the x co-ordinate of the
-c i-th grid point along the x-axis.
-c tx(kx+1)<=x(i-1)<=x(i)<=tx(nx-kx), i=2,...,mx.
-c mx : on entry mx must specify the number of grid points along
-c the x-axis. mx >=1.
-c y : real array of dimension (my).
-c before entry y(j) must be set to the y co-ordinate of the
-c j-th grid point along the y-axis.
-c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my.
-c my : on entry my must specify the number of grid points along
-c the y-axis. my >=1.
-c wrk : real array of dimension lwrk. used as workspace.
-c lwrk : integer, specifying the dimension of wrk.
-c lwrk >= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1)
-c iwrk : integer array of dimension kwrk. used as workspace.
-c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my.
-c
-c output parameters:
-c z : real array of dimension (mx*my).
-c on succesful exit z(my*(i-1)+j) contains the value of the
-c specified partial derivative of s(x,y) at the point
-c (x(i),y(j)),i=1,...,mx;j=1,...,my.
-c ier : integer error flag
-c ier=0 : normal return
-c ier=10: invalid input data (see restrictions)
-c
-c restrictions:
-c mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky, kwrk>=mx+my
-c lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1),
-c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx
-c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my
-c
-c other subroutines required:
-c fpbisp,fpbspl
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1989
-c
-c ..scalar arguments..
- integer nx,ny,kx,ky,nux,nuy,mx,my,lwrk,kwrk,ier
-c ..array arguments..
- integer iwrk(kwrk)
- real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my),
- * wrk(lwrk)
-c ..local scalars..
- integer i,iwx,iwy,j,kkx,kky,kx1,ky1,lx,ly,lwest,l1,l2,m,m0,m1,
- * nc,nkx1,nky1,nxx,nyy
- real*8 ak,fac
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- kx1 = kx+1
- ky1 = ky+1
- nkx1 = nx-kx1
- nky1 = ny-ky1
- nc = nkx1*nky1
- if(nux.lt.0 .or. nux.ge.kx) go to 400
- if(nuy.lt.0 .or. nuy.ge.ky) go to 400
- lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my
- if(lwrk.lt.lwest) go to 400
- if(kwrk.lt.(mx+my)) go to 400
- if (mx.lt.1) go to 400
- if (mx.eq.1) go to 30
- go to 10
- 10 do 20 i=2,mx
- if(x(i).lt.x(i-1)) go to 400
- 20 continue
- 30 if (my.lt.1) go to 400
- if (my.eq.1) go to 60
- go to 40
- 40 do 50 i=2,my
- if(y(i).lt.y(i-1)) go to 400
- 50 continue
- 60 ier = 0
- nxx = nkx1
- nyy = nky1
- kkx = kx
- kky = ky
-c the partial derivative of order (nux,nuy) of a bivariate spline of
-c degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy.
-c we calculate the b-spline coefficients of this spline
- do 70 i=1,nc
- wrk(i) = c(i)
- 70 continue
- if(nux.eq.0) go to 200
- lx = 1
- do 100 j=1,nux
- ak = kkx
- nxx = nxx-1
- l1 = lx
- m0 = 1
- do 90 i=1,nxx
- l1 = l1+1
- l2 = l1+kkx
- fac = tx(l2)-tx(l1)
- if(fac.le.0.) go to 90
- do 80 m=1,nyy
- m1 = m0+nyy
- wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac
- m0 = m0+1
- 80 continue
- 90 continue
- lx = lx+1
- kkx = kkx-1
- 100 continue
- 200 if(nuy.eq.0) go to 300
- ly = 1
- do 230 j=1,nuy
- ak = kky
- nyy = nyy-1
- l1 = ly
- do 220 i=1,nyy
- l1 = l1+1
- l2 = l1+kky
- fac = ty(l2)-ty(l1)
- if(fac.le.0.) go to 220
- m0 = i
- do 210 m=1,nxx
- m1 = m0+1
- wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac
- m0 = m0+nky1
- 210 continue
- 220 continue
- ly = ly+1
- kky = kky-1
- 230 continue
- m0 = nyy
- m1 = nky1
- do 250 m=2,nxx
- do 240 i=1,nyy
- m0 = m0+1
- m1 = m1+1
- wrk(m0) = wrk(m1)
- 240 continue
- m1 = m1+nuy
- 250 continue
-c we partition the working space and evaluate the partial derivative
- 300 iwx = 1+nxx*nyy
- iwy = iwx+mx*(kx1-nux)
- call fpbisp(tx(nux+1),nx-2*nux,ty(nuy+1),ny-2*nuy,wrk,kkx,kky,
- * x,mx,y,my,z,wrk(iwx),wrk(iwy),iwrk(1),iwrk(mx+1))
- 400 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/parsur.f
===================================================================
--- branches/Interpolate1D/fitpack/parsur.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/parsur.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,391 +0,0 @@
- subroutine parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest,
- * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c given the set of ordered points f(i,j) in the idim-dimensional space,
-c corresponding to grid values (u(i),v(j)) ,i=1,...,mu ; j=1,...,mv,
-c parsur determines a smooth approximating spline surface s(u,v) , i.e.
-c f1 = s1(u,v)
-c ... u(1) <= u <= u(mu) ; v(1) <= v <= v(mv)
-c fidim = sidim(u,v)
-c with sl(u,v), l=1,2,...,idim bicubic spline functions with common
-c knots tu(i),i=1,...,nu in the u-variable and tv(j),j=1,...,nv in the
-c v-variable.
-c in addition, these splines will be periodic in the variable u if
-c ipar(1) = 1 and periodic in the variable v if ipar(2) = 1.
-c if iopt=-1, parsur determines the least-squares bicubic spline
-c surface according to a given set of knots.
-c if iopt>=0, the number of knots of s(u,v) and their position
-c is chosen automatically by the routine. the smoothness of s(u,v) is
-c achieved by minimalizing the discontinuity jumps of the derivatives
-c of the splines at the knots. the amount of smoothness of s(u,v) is
-c determined by the condition that
-c fp=sumi=1,mu(sumj=1,mv(dist(f(i,j)-s(u(i),v(j)))**2))<=s,
-c with s a given non-negative constant.
-c the fit s(u,v) is given in its b-spline representation and can be
-c evaluated by means of routine surev.
-c
-c calling sequence:
-c call parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest,nu,tu,
-c * nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer flag. unchanged on exit.
-c on entry iopt must specify whether a least-squares surface
-c (iopt=-1) or a smoothing surface (iopt=0 or 1)must be
-c determined.
-c if iopt=0 the routine will start with the initial set of
-c knots needed for determining the least-squares polynomial
-c surface.
-c if iopt=1 the routine will continue with the set of knots
-c found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt = 1 or iopt = 0.
-c ipar : integer array of dimension 2. unchanged on exit.
-c on entry ipar(1) must specify whether (ipar(1)=1) or not
-c (ipar(1)=0) the splines must be periodic in the variable u.
-c on entry ipar(2) must specify whether (ipar(2)=1) or not
-c (ipar(2)=0) the splines must be periodic in the variable v.
-c idim : integer. on entry idim must specify the dimension of the
-c surface. 1 <= idim <= 3. unchanged on exit.
-c mu : integer. on entry mu must specify the number of grid points
-c along the u-axis. unchanged on exit.
-c mu >= mumin where mumin=4-2*ipar(1)
-c u : real array of dimension at least (mu). before entry, u(i)
-c must be set to the u-co-ordinate of the i-th grid point
-c along the u-axis, for i=1,2,...,mu. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c mv : integer. on entry mv must specify the number of grid points
-c along the v-axis. unchanged on exit.
-c mv >= mvmin where mvmin=4-2*ipar(2)
-c v : real array of dimension at least (mv). before entry, v(j)
-c must be set to the v-co-ordinate of the j-th grid point
-c along the v-axis, for j=1,2,...,mv. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c f : real array of dimension at least (mu*mv*idim).
-c before entry, f(mu*mv*(l-1)+mv*(i-1)+j) must be set to the
-c l-th co-ordinate of the data point corresponding to the
-c the grid point (u(i),v(j)) for l=1,...,idim ,i=1,...,mu
-c and j=1,...,mv. unchanged on exit.
-c if ipar(1)=1 it is expected that f(mu*mv*(l-1)+mv*(mu-1)+j)
-c = f(mu*mv*(l-1)+j), l=1,...,idim ; j=1,...,mv
-c if ipar(2)=1 it is expected that f(mu*mv*(l-1)+mv*(i-1)+mv)
-c = f(mu*mv*(l-1)+mv*(i-1)+1), l=1,...,idim ; i=1,...,mu
-c s : real. on entry (if iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c nuest : integer. unchanged on exit.
-c nvest : integer. unchanged on exit.
-c on entry, nuest and nvest must specify an upper bound for the
-c number of knots required in the u- and v-directions respect.
-c these numbers will also determine the storage space needed by
-c the routine. nuest >= 8, nvest >= 8.
-c in most practical situation nuest = mu/2, nvest=mv/2, will
-c be sufficient. always large enough are nuest=mu+4+2*ipar(1),
-c nvest = mv+4+2*ipar(2), the number of knots needed for
-c interpolation (s=0). see also further comments.
-c nu : integer.
-c unless ier=10 (in case iopt>=0), nu will contain the total
-c number of knots with respect to the u-variable, of the spline
-c surface returned. if the computation mode iopt=1 is used,
-c the value of nu should be left unchanged between subsequent
-c calls. in case iopt=-1, the value of nu should be specified
-c on entry.
-c tu : real array of dimension at least (nuest).
-c on succesful exit, this array will contain the knots of the
-c splines with respect to the u-variable, i.e. the position of
-c the interior knots tu(5),...,tu(nu-4) as well as the position
-c of the additional knots tu(1),...,tu(4) and tu(nu-3),...,
-c tu(nu) needed for the b-spline representation.
-c if the computation mode iopt=1 is used,the values of tu(1)
-c ...,tu(nu) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values tu(5),
-c ...tu(nu-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c nv : integer.
-c unless ier=10 (in case iopt>=0), nv will contain the total
-c number of knots with respect to the v-variable, of the spline
-c surface returned. if the computation mode iopt=1 is used,
-c the value of nv should be left unchanged between subsequent
-c calls. in case iopt=-1, the value of nv should be specified
-c on entry.
-c tv : real array of dimension at least (nvest).
-c on succesful exit, this array will contain the knots of the
-c splines with respect to the v-variable, i.e. the position of
-c the interior knots tv(5),...,tv(nv-4) as well as the position
-c of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
-c tv(nv) needed for the b-spline representation.
-c if the computation mode iopt=1 is used,the values of tv(1)
-c ...,tv(nv) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values tv(5),
-c ...tv(nv-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c c : real array of dimension at least (nuest-4)*(nvest-4)*idim.
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(u,v)
-c fp : real. unless ier=10, fp contains the sum of squared
-c residuals of the spline surface returned.
-c wrk : real array of dimension (lwrk). used as workspace.
-c if the computation mode iopt=1 is used the values of
-c wrk(1),...,wrk(4) should be left unchanged between subsequent
-c calls.
-c lwrk : integer. on entry lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.
-c lwrk must not be too small.
-c lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+
-c 4*(mu+mv)+q*idim where q is the larger of mv and nuest.
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c if the computation mode iopt=1 is used the values of
-c iwrk(1),.,iwrk(3) should be left unchanged between subsequent
-c calls.
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= 3+mu+mv+nuest+nvest.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the surface returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline surface returned is an
-c interpolating surface (fp=0).
-c ier=-2 : normal return. the surface returned is the least-squares
-c polynomial surface. in this extreme case fp gives the
-c upper bound for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters nuest and
-c nvest.
-c probably causes : nuest or nvest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the least-squares surface
-c according to the current set of knots. the parameter fp
-c gives the corresponding sum of squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing surface with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing surface
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 0<=ipar(1)<=1, 0<=ipar(2)<=1, 1 <=idim<=3
-c mu >= 4-2*ipar(1),mv >= 4-2*ipar(2), nuest >=8, nvest >= 8,
-c kwrk>=3+mu+mv+nuest+nvest,
-c lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))
-c +4*(mu+mv)+max(nuest,mv)*idim
-c u(i-1)<u(i),i=2,..,mu, v(i-1)<v(i),i=2,...,mv
-c if iopt=-1: 8<=nu<=min(nuest,mu+4+2*ipar(1))
-c u(1)<tu(5)<tu(6)<...<tu(nu-4)<u(mu)
-c 8<=nv<=min(nvest,mv+4+2*ipar(2))
-c v(1)<tv(5)<tv(6)<...<tv(nv-4)<v(mv)
-c the schoenberg-whitney conditions, i.e. there must
-c be subset of grid co-ordinates uu(p) and vv(q) such
-c that tu(p) < uu(p) < tu(p+4) ,p=1,...,nu-4
-c tv(q) < vv(q) < tv(q+4) ,q=1,...,nv-4
-c (see fpchec or fpchep)
-c if iopt>=0: s>=0
-c if s=0: nuest>=mu+4+2*ipar(1)
-c nvest>=mv+4+2*ipar(2)
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the surface will be too smooth and signal will be
-c lost ; if s is too small the surface will pick up too much noise. in
-c the extreme cases the program will return an interpolating surface
-c if s=0 and the constrained least-squares polynomial surface if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the accuracy of the data values.
-c if the user has an idea of the statistical errors on the data, he
-c can also find a proper estimate for s. for, by assuming that, if he
-c specifies the right s, parsur will return a surface s(u,v) which
-c exactly reproduces the surface underlying the data he can evaluate
-c the sum(dist(f(i,j)-s(u(i),v(j)))**2) to find a good estimate for s.
-c for example, if he knows that the statistical errors on his f(i,j)-
-c values is not greater than 0.1, he may expect that a good s should
-c have a value not larger than mu*mv*(0.1)**2.
-c if nothing is known about the statistical error in f(i,j), s must
-c be determined by trial and error, taking account of the comments
-c above. the best is then to start with a very large value of s (to
-c determine the le-sq polynomial surface and the corresponding upper
-c bound fp0 for s) and then to progressively decrease the value of s
-c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
-c and more carefully as the approximation shows more detail) to
-c obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt = 1 the program will continue with the knots found at
-c the last call of the routine. this will save a lot of computation
-c time if parsur is called repeatedly for different values of s.
-c the number of knots of the surface returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c surface underlying the data. if the computation mode iopt = 1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt=1,the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c parsur once more with the chosen value for s but now with iopt=0.
-c indeed, parsur may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds nuest and
-c nvest. indeed, if at a certain stage in parsur the number of knots
-c in one direction (say nu) has reached the value of its upper bound
-c (nuest), then from that moment on all subsequent knots are added
-c in the other (v) direction. this may indicate that the value of
-c nuest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c for example, by setting nuest=8 (the lowest allowable value for
-c nuest), the user can indicate that he wants an approximation with
-c splines which are simple cubic polynomials in the variable u.
-c
-c other subroutines required:
-c fppasu,fpchec,fpchep,fpknot,fprati,fpgrpa,fptrnp,fpback,
-c fpbacp,fpbspl,fptrpe,fpdisc,fpgivs,fprota
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1989
-c
-c ..
-c ..scalar arguments..
- real*8 s,fp
- integer iopt,idim,mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier
-c ..array arguments..
- real*8 u(mu),v(mv),f(mu*mv*idim),tu(nuest),tv(nvest),
- * c((nuest-4)*(nvest-4)*idim),wrk(lwrk)
- integer ipar(2),iwrk(kwrk)
-c ..local scalars..
- real*8 tol,ub,ue,vb,ve,peru,perv
- integer i,j,jwrk,kndu,kndv,knru,knrv,kwest,l1,l2,l3,l4,
- * lfpu,lfpv,lwest,lww,maxit,nc,mf,mumin,mvmin
-c ..function references..
- integer max0
-c ..subroutine references..
-c fppasu,fpchec,fpchep
-c ..
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 200
- if(ipar(1).lt.0 .or. ipar(1).gt.1) go to 200
- if(ipar(2).lt.0 .or. ipar(2).gt.1) go to 200
- if(idim.le.0 .or. idim.gt.3) go to 200
- mumin = 4-2*ipar(1)
- if(mu.lt.mumin .or. nuest.lt.8) go to 200
- mvmin = 4-2*ipar(2)
- if(mv.lt.mvmin .or. nvest.lt.8) go to 200
- mf = mu*mv
- nc = (nuest-4)*(nvest-4)
- lwest = 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+
- * 4*(mu+mv)+max0(nuest,mv)*idim
- kwest = 3+mu+mv+nuest+nvest
- if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200
- do 10 i=2,mu
- if(u(i-1).ge.u(i)) go to 200
- 10 continue
- do 20 i=2,mv
- if(v(i-1).ge.v(i)) go to 200
- 20 continue
- if(iopt.ge.0) go to 100
- if(nu.lt.8 .or. nu.gt.nuest) go to 200
- ub = u(1)
- ue = u(mu)
- if (ipar(1).ne.0) go to 40
- j = nu
- do 30 i=1,4
- tu(i) = ub
- tu(j) = ue
- j = j-1
- 30 continue
- call fpchec(u,mu,tu,nu,3,ier)
- if(ier.ne.0) go to 200
- go to 60
- 40 l1 = 4
- l2 = l1
- l3 = nu-3
- l4 = l3
- peru = ue-ub
- tu(l2) = ub
- tu(l3) = ue
- do 50 j=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tu(l2) = tu(l4)-peru
- tu(l3) = tu(l1)+peru
- 50 continue
- call fpchep(u,mu,tu,nu,3,ier)
- if(ier.ne.0) go to 200
- 60 if(nv.lt.8 .or. nv.gt.nvest) go to 200
- vb = v(1)
- ve = v(mv)
- if (ipar(2).ne.0) go to 80
- j = nv
- do 70 i=1,4
- tv(i) = vb
- tv(j) = ve
- j = j-1
- 70 continue
- call fpchec(v,mv,tv,nv,3,ier)
- if(ier.ne.0) go to 200
- go to 150
- 80 l1 = 4
- l2 = l1
- l3 = nv-3
- l4 = l3
- perv = ve-vb
- tv(l2) = vb
- tv(l3) = ve
- do 90 j=1,3
- l1 = l1+1
- l2 = l2-1
- l3 = l3+1
- l4 = l4-1
- tv(l2) = tv(l4)-perv
- tv(l3) = tv(l1)+perv
- 90 continue
- call fpchep(v,mv,tv,nv,3,ier)
- if (ier.eq.0) go to 150
- go to 200
- 100 if(s.lt.0.) go to 200
- if(s.eq.0. .and. (nuest.lt.(mu+4+2*ipar(1)) .or.
- * nvest.lt.(mv+4+2*ipar(2))) )go to 200
- ier = 0
-c we partition the working space and determine the spline approximation
- 150 lfpu = 5
- lfpv = lfpu+nuest
- lww = lfpv+nvest
- jwrk = lwrk-4-nuest-nvest
- knru = 4
- knrv = knru+mu
- kndu = knrv+mv
- kndv = kndu+nuest
- call fppasu(iopt,ipar,idim,u,mu,v,mv,f,mf,s,nuest,nvest,
- * tol,maxit,nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),
- * wrk(lfpu),wrk(lfpv),iwrk(1),iwrk(2),iwrk(3),iwrk(knru),
- * iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier)
- 200 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/percur.f
===================================================================
--- branches/Interpolate1D/fitpack/percur.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/percur.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,274 +0,0 @@
- subroutine percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp,
- * wrk,lwrk,iwrk,ier)
-c given the set of data points (x(i),y(i)) and the set of positive
-c numbers w(i),i=1,2,...,m-1, subroutine percur determines a smooth
-c periodic spline approximation of degree k with period per=x(m)-x(1).
-c if iopt=-1 percur calculates the weighted least-squares periodic
-c spline according to a given set of knots.
-c if iopt>=0 the number of knots of the spline s(x) and the position
-c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
-c ness of s(x) is then achieved by minimalizing the discontinuity
-c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,...,
-c n-k-1. the amount of smoothness is determined by the condition that
-c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non-
-c negative constant, called the smoothing factor.
-c the fit s(x) is given in the b-spline representation (b-spline coef-
-c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of
-c subroutine splev.
-c
-c calling sequence:
-c call percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp,wrk,
-c * lwrk,iwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares spline (iopt=-1) or a smoothing spline (iopt=
-c 0 or 1) must be determined. if iopt=0 the routine will start
-c with an initial set of knots t(i)=x(1)+(x(m)-x(1))*(i-k-1),
-c i=1,2,...,2*k+2. if iopt=1 the routine will continue with
-c the knots found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately
-c preceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m > 1. unchanged on exit.
-c x : real array of dimension at least (m). before entry, x(i)
-c must be set to the i-th value of the independent variable x,
-c for i=1,2,...,m. these values must be supplied in strictly
-c ascending order. x(m) only indicates the length of the
-c period of the spline, i.e per=x(m)-x(1).
-c unchanged on exit.
-c y : real array of dimension at least (m). before entry, y(i)
-c must be set to the i-th value of the dependent variable y,
-c for i=1,2,...,m-1. the element y(m) is not used.
-c unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i)
-c must be set to the i-th value in the set of weights. the
-c w(i) must be strictly positive. w(m) is not used.
-c see also further comments. unchanged on exit.
-c k : integer. on entry k must specify the degree of the spline.
-c 1<=k<=5. it is recommended to use cubic splines (k=3).
-c the user is strongly dissuaded from choosing k even,together
-c with a small s-value. unchanged on exit.
-c s : real.on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments.
-c nest : integer. on entry nest must contain an over-estimate of the
-c total number of knots of the spline returned, to indicate
-c the storage space available to the routine. nest >=2*k+2.
-c in most practical situation nest=m/2 will be sufficient.
-c always large enough is nest=m+2*k,the number of knots needed
-c for interpolation (s=0). unchanged on exit.
-c n : integer.
-c unless ier = 10 (in case iopt >=0), n will contain the
-c total number of knots of the spline approximation returned.
-c if the computation mode iopt=1 is used this value of n
-c should be left unchanged between subsequent calls.
-c in case iopt=-1, the value of n must be specified on entry.
-c t : real array of dimension at least (nest).
-c on succesful exit, this array will contain the knots of the
-c spline,i.e. the position of the interior knots t(k+2),t(k+3)
-c ...,t(n-k-1) as well as the position of the additional knots
-c t(1),t(2),...,t(k+1)=x(1) and t(n-k)=x(m),..,t(n) needed for
-c the b-spline representation.
-c if the computation mode iopt=1 is used, the values of t(1),
-c t(2),...,t(n) should be left unchanged between subsequent
-c calls. if the computation mode iopt=-1 is used, the values
-c t(k+2),...,t(n-k-1) must be supplied by the user, before
-c entry. see also the restrictions (ier=10).
-c c : real array of dimension at least (nest).
-c on succesful exit, this array will contain the coefficients
-c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x)
-c fp : real. unless ier = 10, fp contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c wrk : real array of dimension at least (m*(k+1)+nest*(8+5*k)).
-c used as working space. if the computation mode iopt=1 is
-c used, the values wrk(1),...,wrk(n) should be left unchanged
-c between subsequent calls.
-c lwrk : integer. on entry,lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program. lwrk
-c must not be too small (see wrk). unchanged on exit.
-c iwrk : integer array of dimension at least (nest).
-c used as working space. if the computation mode iopt=1 is
-c used,the values iwrk(1),...,iwrk(n) should be left unchanged
-c between subsequent calls.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c periodic spline (fp=0).
-c ier=-2 : normal return. the spline returned is the weighted least-
-c squares constant. in this extreme case fp gives the upper
-c bound fp0 for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameter nest.
-c probably causes : nest too small. if nest is already
-c large (say nest > m/2), it may also indicate that s is
-c too small
-c the approximation returned is the least-squares periodic
-c spline according to the knots t(1),t(2),...,t(n). (n=nest)
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,...,m-1
-c x(1)<x(2)<...<x(m), lwrk>=(k+1)*m+nest*(8+5*k)
-c if iopt=-1: 2*k+2<=n<=min(nest,m+2*k)
-c x(1)<t(k+2)<t(k+3)<...<t(n-k-1)<x(m)
-c the schoenberg-whitney conditions, i.e. there
-c must be a subset of data points xx(j) with
-c xx(j) = x(i) or x(i)+(x(m)-x(1)) such that
-c t(j) < xx(j) < t(j+k+1), j=k+1,...,n-k-1
-c if iopt>=0: s>=0
-c if s=0 : nest >= m+2*k
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating periodic
-c spline if s=0 and the weighted least-squares constant if s is very
-c large. between these extremes, a properly chosen s will result in
-c a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in y(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c constant and the corresponding upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximation shows more detail) to obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if percur is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. but, if the computation mode iopt=1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c percur once more with the selected value for s but now with iopt=0.
-c indeed, percur may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c
-c other subroutines required:
-c fpbacp,fpbspl,fpchep,fpperi,fpdisc,fpgivs,fpknot,fprati,fprota
-c
-c references:
-c dierckx p. : algorithms for smoothing data with periodic and
-c parametric splines, computer graphics and image
-c processing 20 (1982) 171-184.
-c dierckx p. : algorithms for smoothing data with periodic and param-
-c etric splines, report tw55, dept. computer science,
-c k.u.leuven, 1981.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- real*8 s,fp
- integer iopt,m,k,nest,n,lwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk)
- integer iwrk(nest)
-c ..local scalars..
- real*8 per,tol
- integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest,
- * maxit,m1,nmin
-c ..subroutine references..
-c perper,pcheck
-c ..
-c we set up the parameters tol and maxit
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(k.le.0 .or. k.gt.5) go to 50
- k1 = k+1
- k2 = k1+1
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 50
- nmin = 2*k1
- if(m.lt.2 .or. nest.lt.nmin) go to 50
- lwest = m*k1+nest*(8+5*k)
- if(lwrk.lt.lwest) go to 50
- m1 = m-1
- do 10 i=1,m1
- if(x(i).ge.x(i+1) .or. w(i).le.0.) go to 50
- 10 continue
- if(iopt.ge.0) go to 30
- if(n.le.nmin .or. n.gt.nest) go to 50
- per = x(m)-x(1)
- j1 = k1
- t(j1) = x(1)
- i1 = n-k
- t(i1) = x(m)
- j2 = j1
- i2 = i1
- do 20 i=1,k
- i1 = i1+1
- i2 = i2-1
- j1 = j1+1
- j2 = j2-1
- t(j2) = t(i2)-per
- t(i1) = t(j1)+per
- 20 continue
- call fpchep(x,m,t,n,k,ier)
- if (ier.eq.0) go to 40
- go to 50
- 30 if(s.lt.0.) go to 50
- if(s.eq.0. .and. nest.lt.(m+2*k)) go to 50
- ier = 0
-c we partition the working space and determine the spline approximation.
- 40 ifp = 1
- iz = ifp+nest
- ia1 = iz+nest
- ia2 = ia1+nest*k1
- ib = ia2+nest*k
- ig1 = ib+nest*k2
- ig2 = ig1+nest*k2
- iq = ig2+nest*k1
- call fpperi(iopt,x,y,w,m,k,s,nest,tol,maxit,k1,k2,n,t,c,fp,
- * wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1),wrk(ig2),
- * wrk(iq),iwrk,ier)
- 50 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/pogrid.f
===================================================================
--- branches/Interpolate1D/fitpack/pogrid.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/pogrid.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,466 +0,0 @@
- subroutine pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s,nuest,nvest,
- * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c subroutine pogrid fits a function f(x,y) to a set of data points
-c z(i,j) given at the nodes (x,y)=(u(i)*cos(v(j)),u(i)*sin(v(j))),
-c i=1,...,mu ; j=1,...,mv , of a radius-angle grid over a disc
-c x ** 2 + y ** 2 <= r ** 2 .
-c
-c this approximation problem is reduced to the determination of a
-c bicubic spline s(u,v) smoothing the data (u(i),v(j),z(i,j)) on the
-c rectangle 0<=u<=r, v(1)<=v<=v(1)+2*pi
-c in order to have continuous partial derivatives
-c i+j
-c d f(0,0)
-c g(i,j) = ----------
-c i j
-c dx dy
-c
-c s(u,v)=f(x,y) must satisfy the following conditions
-c
-c (1) s(0,v) = g(0,0) v(1)<=v<= v(1)+2*pi
-c
-c d s(0,v)
-c (2) -------- = cos(v)*g(1,0)+sin(v)*g(0,1) v(1)<=v<= v(1)+2*pi
-c d u
-c
-c moreover, s(u,v) must be periodic in the variable v, i.e.
-c
-c j j
-c d s(u,vb) d s(u,ve)
-c (3) ---------- = --------- 0 <=u<= r, j=0,1,2 , vb=v(1),
-c j j ve=vb+2*pi
-c d v d v
-c
-c the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu;
-c tv(j),j=1,2,...,nv, is chosen automatically by the routine. the
-c smoothness of s(u,v) is achieved by minimalizing the discontinuity
-c jumps of the derivatives of the spline at the knots. the amount of
-c smoothness of s(u,v) is determined by the condition that
-c fp=sumi=1,mu(sumj=1,mv((z(i,j)-s(u(i),v(j)))**2))+(z0-g(0,0))**2<=s,
-c with s a given non-negative constant.
-c the fit s(u,v) is given in its b-spline representation and can be
-c evaluated by means of routine bispev. f(x,y) = s(u,v) can also be
-c evaluated by means of function program evapol.
-c
-c calling sequence:
-c call pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s,nuest,nvest,nu,tu,
-c * ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer array of dimension 3, specifying different options.
-c unchanged on exit.
-c iopt(1):on entry iopt(1) must specify whether a least-squares spline
-c (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be
-c determined.
-c if iopt(1)=0 the routine will start with an initial set of
-c knots tu(i)=0,tu(i+4)=r,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi,i=1,.
-c ...,8.
-c if iopt(1)=1 the routine will continue with the set of knots
-c found at the last call of the routine.
-c attention: a call with iopt(1)=1 must always be immediately
-c preceded by another call with iopt(1) = 1 or iopt(1) = 0.
-c iopt(2):on entry iopt(2) must specify the requested order of conti-
-c nuity for f(x,y) at the origin.
-c if iopt(2)=0 only condition (1) must be fulfilled and
-c if iopt(2)=1 conditions (1)+(2) must be fulfilled.
-c iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not
-c (iopt(3)=0) the approximation f(x,y) must vanish at the
-c boundary of the approximation domain.
-c ider : integer array of dimension 2, specifying different options.
-c unchanged on exit.
-c ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not
-c (ider(1)=-1) there is a data value z0 at the origin.
-c if ider(1)=1, z0 will be considered to be the right function
-c value, and it will be fitted exactly (g(0,0)=z0=c(1)).
-c if ider(1)=0, z0 will be considered to be a data value just
-c like the other data values z(i,j).
-c ider(2):on entry ider(2) must specify whether (ider(2)=1) or not
-c (ider(2)=0) f(x,y) must have vanishing partial derivatives
-c g(1,0) and g(0,1) at the origin. (in case iopt(2)=1)
-c mu : integer. on entry mu must specify the number of grid points
-c along the u-axis. unchanged on exit.
-c mu >= mumin where mumin=4-iopt(3)-ider(2) if ider(1)<0
-c =3-iopt(3)-ider(2) if ider(1)>=0
-c u : real array of dimension at least (mu). before entry, u(i)
-c must be set to the u-co-ordinate of the i-th grid point
-c along the u-axis, for i=1,2,...,mu. these values must be
-c positive and supplied in strictly ascending order.
-c unchanged on exit.
-c mv : integer. on entry mv must specify the number of grid points
-c along the v-axis. mv > 3 . unchanged on exit.
-c v : real array of dimension at least (mv). before entry, v(j)
-c must be set to the v-co-ordinate of the j-th grid point
-c along the v-axis, for j=1,2,...,mv. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c -pi <= v(1) < pi , v(mv) < v(1)+2*pi.
-c z : real array of dimension at least (mu*mv).
-c before entry, z(mv*(i-1)+j) must be set to the data value at
-c the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv.
-c unchanged on exit.
-c z0 : real value. on entry (if ider(1) >=0 ) z0 must specify the
-c data value at the origin. unchanged on exit.
-c r : real value. on entry r must specify the radius of the disk.
-c r>=u(mu) (>u(mu) if iopt(3)=1). unchanged on exit.
-c s : real. on entry (if iopt(1)>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c nuest : integer. unchanged on exit.
-c nvest : integer. unchanged on exit.
-c on entry, nuest and nvest must specify an upper bound for the
-c number of knots required in the u- and v-directions respect.
-c these numbers will also determine the storage space needed by
-c the routine. nuest >= 8, nvest >= 8.
-c in most practical situation nuest = mu/2, nvest=mv/2, will
-c be sufficient. always large enough are nuest=mu+5+iopt(2)+
-c iopt(3), nvest = mv+7, the number of knots needed for
-c interpolation (s=0). see also further comments.
-c nu : integer.
-c unless ier=10 (in case iopt(1)>=0), nu will contain the total
-c number of knots with respect to the u-variable, of the spline
-c approximation returned. if the computation mode iopt(1)=1 is
-c used, the value of nu should be left unchanged between sub-
-c sequent calls. in case iopt(1)=-1, the value of nu should be
-c specified on entry.
-c tu : real array of dimension at least (nuest).
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the u-variable, i.e. the position of
-c the interior knots tu(5),...,tu(nu-4) as well as the position
-c of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...=
-c tu(nu)=r needed for the b-spline representation.
-c if the computation mode iopt(1)=1 is used,the values of tu(1)
-c ...,tu(nu) should be left unchanged between subsequent calls.
-c if the computation mode iopt(1)=-1 is used, the values tu(5),
-c ...tu(nu-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c nv : integer.
-c unless ier=10 (in case iopt(1)>=0), nv will contain the total
-c number of knots with respect to the v-variable, of the spline
-c approximation returned. if the computation mode iopt(1)=1 is
-c used, the value of nv should be left unchanged between sub-
-c sequent calls. in case iopt(1) = -1, the value of nv should
-c be specified on entry.
-c tv : real array of dimension at least (nvest).
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the v-variable, i.e. the position of
-c the interior knots tv(5),...,tv(nv-4) as well as the position
-c of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
-c tv(nv) needed for the b-spline representation.
-c if the computation mode iopt(1)=1 is used,the values of tv(1)
-c ...,tv(nv) should be left unchanged between subsequent calls.
-c if the computation mode iopt(1)=-1 is used, the values tv(5),
-c ...tv(nv-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c c : real array of dimension at least (nuest-4)*(nvest-4).
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(u,v)
-c fp : real. unless ier=10, fp contains the sum of squared
-c residuals of the spline approximation returned.
-c wrk : real array of dimension (lwrk). used as workspace.
-c if the computation mode iopt(1)=1 is used the values of
-c wrk(1),...,wrk(8) should be left unchanged between subsequent
-c calls.
-c lwrk : integer. on entry lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.
-c lwrk must not be too small.
-c lwrk >= 8+nuest*(mv+nvest+3)+nvest*21+4*mu+6*mv+q
-c where q is the larger of (mv+nvest) and nuest.
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c if the computation mode iopt(1)=1 is used the values of
-c iwrk(1),.,iwrk(4) should be left unchanged between subsequent
-c calls.
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= 4+mu+mv+nuest+nvest.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c spline (fp=0).
-c ier=-2 : normal return. the spline returned is the least-squares
-c constrained polynomial. in this extreme case fp gives the
-c upper bound for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters nuest and
-c nvest.
-c probably causes : nuest or nvest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the least-squares spline
-c according to the current set of knots. the parameter fp
-c gives the corresponding sum of squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1,
-c -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0.
-c mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8,
-c kwrk>=4+mu+mv+nuest+nvest,
-c lwrk >= 8+nuest*(mv+nvest+3)+nvest*21+4*mu+6*mv+
-c max(nuest,mv+nvest)
-c 0< u(i-1)<u(i)<=r,i=2,..,mu, (< r if iopt(3)=1)
-c -pi<=v(1)< pi, v(1)<v(i-1)<v(i)<v(1)+2*pi, i=3,...,mv
-c if iopt(1)=-1: 8<=nu<=min(nuest,mu+5+iopt(2)+iopt(3))
-c 0<tu(5)<tu(6)<...<tu(nu-4)<r
-c 8<=nv<=min(nvest,mv+7)
-c v(1)<tv(5)<tv(6)<...<tv(nv-4)<v(1)+2*pi
-c the schoenberg-whitney conditions, i.e. there must
-c be subset of grid co-ordinates uu(p) and vv(q) such
-c that tu(p) < uu(p) < tu(p+4) ,p=1,...,nu-4
-c (iopt(2)=1 and iopt(3)=1 also count for a uu-value
-c tv(q) < vv(q) < tv(q+4) ,q=1,...,nv-4
-c (vv(q) is either a value v(j) or v(j)+2*pi)
-c if iopt(1)>=0: s>=0
-c if s=0: nuest>=mu+5+iopt(2)+iopt(3), nvest>=mv+7
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c pogrid does not allow individual weighting of the data-values.
-c so, if these were determined to widely different accuracies, then
-c perhaps the general data set routine polar should rather be used
-c in spite of efficiency.
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the constrained least-squares polynomial(degrees 3,0)if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the accuracy of the data values.
-c if the user has an idea of the statistical errors on the data, he
-c can also find a proper estimate for s. for, by assuming that, if he
-c specifies the right s, pogrid will return a spline s(u,v) which
-c exactly reproduces the function underlying the data he can evaluate
-c the sum((z(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s
-c for example, if he knows that the statistical errors on his z(i,j)-
-c values is not greater than 0.1, he may expect that a good s should
-c have a value not larger than mu*mv*(0.1)**2.
-c if nothing is known about the statistical error in z(i,j), s must
-c be determined by trial and error, taking account of the comments
-c above. the best is then to start with a very large value of s (to
-c determine the least-squares polynomial and the corresponding upper
-c bound fp0 for s) and then to progressively decrease the value of s
-c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
-c and more carefully as the approximation shows more detail) to
-c obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt(1)=0.
-c if iopt(1) = 1 the program will continue with the knots found at
-c the last call of the routine. this will save a lot of computation
-c time if pogrid is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. if the computation mode iopt(1) = 1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt(1)=1,the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c pogrid once more with the chosen value for s but now with iopt(1)=0.
-c indeed, pogrid may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds nuest and
-c nvest. indeed, if at a certain stage in pogrid the number of knots
-c in one direction (say nu) has reached the value of its upper bound
-c (nuest), then from that moment on all subsequent knots are added
-c in the other (v) direction. this may indicate that the value of
-c nuest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c for example, by setting nuest=8 (the lowest allowable value for
-c nuest), the user can indicate that he wants an approximation which
-c is a simple cubic polynomial in the variable u.
-c
-c other subroutines required:
-c fppogr,fpchec,fpchep,fpknot,fpopdi,fprati,fpgrdi,fpsysy,fpback,
-c fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota
-c
-c references:
-c dierckx p. : fast algorithms for smoothing data over a disc or a
-c sphere using tensor product splines, in "algorithms
-c for approximation", ed. j.c.mason and m.g.cox,
-c clarendon press oxford, 1987, pp. 51-65
-c dierckx p. : fast algorithms for smoothing data over a disc or a
-c sphere using tensor product splines, report tw73, dept.
-c computer science,k.u.leuven, 1985.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : july 1985
-c latest update : march 1989
-c
-c ..
-c ..scalar arguments..
- real*8 z0,r,s,fp
- integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier
-c ..array arguments..
- integer iopt(3),ider(2),iwrk(kwrk)
- real*8 u(mu),v(mv),z(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest),
- * tv(nvest),wrk(lwrk)
-c ..local scalars..
- real*8 per,pi,tol,uu,ve,zmax,zmin,one,half,rn,zb
- integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l,
- * ldz,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc
-c ..function references..
- real*8 datan2
- integer max0
-c ..subroutine references..
-c fpchec,fpchep,fppogr
-c ..
-c set constants
- one = 1d0
- half = 0.5e0
- pi = datan2(0d0,-one)
- per = pi+pi
- ve = v(1)+per
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations, a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200
- if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200
- if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200
- if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200
- if(ider(2).lt.0 .or. ider(2).gt.1) go to 200
- if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200
- mumin = 4-iopt(3)-ider(2)
- if(ider(1).ge.0) mumin = mumin-1
- if(mu.lt.mumin .or. mv.lt.4) go to 200
- if(nuest.lt.8 .or. nvest.lt.8) go to 200
- m = mu*mv
- nc = (nuest-4)*(nvest-4)
- lwest = 8+nuest*(mv+nvest+3)+21*nvest+4*mu+6*mv+
- * max0(nuest,mv+nvest)
- kwest = 4+mu+mv+nuest+nvest
- if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200
- if(u(1).le.0. .or. u(mu).gt.r) go to 200
- if(iopt(3).eq.0) go to 10
- if(u(mu).eq.r) go to 200
- 10 if(mu.eq.1) go to 30
- do 20 i=2,mu
- if(u(i-1).ge.u(i)) go to 200
- 20 continue
- 30 if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200
- if(v(mv).ge.v(1)+per) go to 200
- do 40 i=2,mv
- if(v(i-1).ge.v(i)) go to 200
- 40 continue
- if(iopt(1).gt.0) go to 140
-c if not given, we compute an estimate for z0.
- if(ider(1).lt.0) go to 50
- zb = z0
- go to 70
- 50 zb = 0.
- do 60 i=1,mv
- zb = zb+z(i)
- 60 continue
- rn = mv
- zb = zb/rn
-c we determine the range of z-values.
- 70 zmin = zb
- zmax = zb
- do 80 i=1,m
- if(z(i).lt.zmin) zmin = z(i)
- if(z(i).gt.zmax) zmax = z(i)
- 80 continue
- wrk(5) = zb
- wrk(6) = 0.
- wrk(7) = 0.
- wrk(8) = zmax -zmin
- iwrk(4) = mu
- if(iopt(1).eq.0) go to 140
- if(nu.lt.8 .or. nu.gt.nuest) go to 200
- if(nv.lt.11 .or. nv.gt.nvest) go to 200
- j = nu
- do 90 i=1,4
- tu(i) = 0.
- tu(j) = r
- j = j-1
- 90 continue
- l = 9
- wrk(l) = 0.
- if(iopt(2).eq.0) go to 100
- l = l+1
- uu = u(1)
- if(uu.gt.tu(5)) uu = tu(5)
- wrk(l) = uu*half
- 100 do 110 i=1,mu
- l = l+1
- wrk(l) = u(i)
- 110 continue
- if(iopt(3).eq.0) go to 120
- l = l+1
- wrk(l) = r
- 120 muu = l-8
- call fpchec(wrk(9),muu,tu,nu,3,ier)
- if(ier.ne.0) go to 200
- j1 = 4
- tv(j1) = v(1)
- i1 = nv-3
- tv(i1) = ve
- j2 = j1
- i2 = i1
- do 130 i=1,3
- i1 = i1+1
- i2 = i2-1
- j1 = j1+1
- j2 = j2-1
- tv(j2) = tv(i2)-per
- tv(i1) = tv(j1)+per
- 130 continue
- l = 9
- do 135 i=1,mv
- wrk(l) = v(i)
- l = l+1
- 135 continue
- wrk(l) = ve
- call fpchep(wrk(9),mv+1,tv,nv,3,ier)
- if (ier.eq.0) go to 150
- go to 200
- 140 if(s.lt.0.) go to 200
- if(s.eq.0. .and. (nuest.lt.(mu+5+iopt(2)+iopt(3)) .or.
- * nvest.lt.(mv+7)) ) go to 200
-c we partition the working space and determine the spline approximation
- 150 ldz = 5
- lfpu = 9
- lfpv = lfpu+nuest
- lww = lfpv+nvest
- jwrk = lwrk-8-nuest-nvest
- knru = 5
- knrv = knru+mu
- kndu = knrv+mv
- kndv = kndu+nuest
- call fppogr(iopt,ider,u,mu,v,mv,z,m,zb,r,s,nuest,nvest,tol,maxit,
- * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu),
- * wrk(lfpv),wrk(ldz),wrk(8),iwrk(1),iwrk(2),iwrk(3),iwrk(4),
- * iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier)
- 200 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/polar.f
===================================================================
--- branches/Interpolate1D/fitpack/polar.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/polar.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,450 +0,0 @@
- subroutine polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,eps,nu,tu,
- * nv,tv,u,v,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
-c subroutine polar fits a smooth function f(x,y) to a set of data
-c points (x(i),y(i),z(i)) scattered arbitrarily over an approximation
-c domain x**2+y**2 <= rad(atan(y/x))**2. through the transformation
-c x = u*rad(v)*cos(v) , y = u*rad(v)*sin(v)
-c the approximation problem is reduced to the determination of a bi-
-c cubic spline s(u,v) fitting a corresponding set of data points
-c (u(i),v(i),z(i)) on the rectangle 0<=u<=1,-pi<=v<=pi.
-c in order to have continuous partial derivatives
-c i+j
-c d f(0,0)
-c g(i,j) = ----------
-c i j
-c dx dy
-c
-c s(u,v)=f(x,y) must satisfy the following conditions
-c
-c (1) s(0,v) = g(0,0) -pi <=v<= pi.
-c
-c d s(0,v)
-c (2) -------- = rad(v)*(cos(v)*g(1,0)+sin(v)*g(0,1))
-c d u
-c -pi <=v<= pi
-c 2
-c d s(0,v) 2 2 2
-c (3) -------- = rad(v)*(cos(v)*g(2,0)+sin(v)*g(0,2)+sin(2*v)*g(1,1))
-c 2
-c d u -pi <=v<= pi
-c
-c moreover, s(u,v) must be periodic in the variable v, i.e.
-c
-c j j
-c d s(u,-pi) d s(u,pi)
-c (4) ---------- = --------- 0 <=u<= 1, j=0,1,2
-c j j
-c d v d v
-c
-c if iopt(1) < 0 circle calculates a weighted least-squares spline
-c according to a given set of knots in u- and v- direction.
-c if iopt(1) >=0, the number of knots in each direction and their pos-
-c ition tu(j),j=1,2,...,nu ; tv(j),j=1,2,...,nv are chosen automatical-
-c ly by the routine. the smoothness of s(u,v) is then achieved by mini-
-c malizing the discontinuity jumps of the derivatives of the spline
-c at the knots. the amount of smoothness of s(u,v) is determined by
-c the condition that fp = sum((w(i)*(z(i)-s(u(i),v(i))))**2) be <= s,
-c with s a given non-negative constant.
-c the bicubic spline is given in its standard b-spline representation
-c and the corresponding function f(x,y) can be evaluated by means of
-c function program evapol.
-c
-c calling sequence:
-c call polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,eps,nu,tu,
-c * nv,tv,u,v,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer array of dimension 3, specifying different options.
-c unchanged on exit.
-c iopt(1):on entry iopt(1) must specify whether a weighted
-c least-squares polar spline (iopt(1)=-1) or a smoothing
-c polar spline (iopt(1)=0 or 1) must be determined.
-c if iopt(1)=0 the routine will start with an initial set of
-c knots tu(i)=0,tu(i+4)=1,i=1,...,4;tv(i)=(2*i-9)*pi,i=1,...,8.
-c if iopt(1)=1 the routine will continue with the set of knots
-c found at the last call of the routine.
-c attention: a call with iopt(1)=1 must always be immediately
-c preceded by another call with iopt(1) = 1 or iopt(1) = 0.
-c iopt(2):on entry iopt(2) must specify the requested order of conti-
-c nuity for f(x,y) at the origin.
-c if iopt(2)=0 only condition (1) must be fulfilled,
-c if iopt(2)=1 conditions (1)+(2) must be fulfilled and
-c if iopt(2)=2 conditions (1)+(2)+(3) must be fulfilled.
-c iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not
-c (iopt(3)=0) the approximation f(x,y) must vanish at the
-c boundary of the approximation domain.
-c m : integer. on entry m must specify the number of data points.
-c m >= 4-iopt(2)-iopt(3) unchanged on exit.
-c x : real array of dimension at least (m).
-c y : real array of dimension at least (m).
-c z : real array of dimension at least (m).
-c before entry, x(i),y(i),z(i) must be set to the co-ordinates
-c of the i-th data point, for i=1,...,m. the order of the data
-c points is immaterial. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i) must
-c be set to the i-th value in the set of weights. the w(i) must
-c be strictly positive. unchanged on exit.
-c rad : real function subprogram defining the boundary of the approx-
-c imation domain, i.e x = rad(v)*cos(v) , y = rad(v)*sin(v),
-c -pi <= v <= pi.
-c must be declared external in the calling (sub)program.
-c s : real. on entry (in case iopt(1) >=0) s must specify the
-c smoothing factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c nuest : integer. unchanged on exit.
-c nvest : integer. unchanged on exit.
-c on entry, nuest and nvest must specify an upper bound for the
-c number of knots required in the u- and v-directions resp.
-c these numbers will also determine the storage space needed by
-c the routine. nuest >= 8, nvest >= 8.
-c in most practical situation nuest = nvest = 8+sqrt(m/2) will
-c be sufficient. see also further comments.
-c eps : real.
-c on entry, eps must specify a threshold for determining the
-c effective rank of an over-determined linear system of equat-
-c ions. 0 < eps < 1. if the number of decimal digits in the
-c computer representation of a real number is q, then 10**(-q)
-c is a suitable value for eps in most practical applications.
-c unchanged on exit.
-c nu : integer.
-c unless ier=10 (in case iopt(1) >=0),nu will contain the total
-c number of knots with respect to the u-variable, of the spline
-c approximation returned. if the computation mode iopt(1)=1
-c is used, the value of nu should be left unchanged between
-c subsequent calls.
-c in case iopt(1)=-1,the value of nu must be specified on entry
-c tu : real array of dimension at least nuest.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the u-variable, i.e. the position
-c of the interior knots tu(5),...,tu(nu-4) as well as the
-c position of the additional knots tu(1)=...=tu(4)=0 and
-c tu(nu-3)=...=tu(nu)=1 needed for the b-spline representation
-c if the computation mode iopt(1)=1 is used,the values of
-c tu(1),...,tu(nu) should be left unchanged between subsequent
-c calls. if the computation mode iopt(1)=-1 is used,the values
-c tu(5),...tu(nu-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c nv : integer.
-c unless ier=10 (in case iopt(1)>=0), nv will contain the total
-c number of knots with respect to the v-variable, of the spline
-c approximation returned. if the computation mode iopt(1)=1
-c is used, the value of nv should be left unchanged between
-c subsequent calls. in case iopt(1)=-1, the value of nv should
-c be specified on entry.
-c tv : real array of dimension at least nvest.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the v-variable, i.e. the position of
-c the interior knots tv(5),...,tv(nv-4) as well as the position
-c of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
-c tv(nv) needed for the b-spline representation.
-c if the computation mode iopt(1)=1 is used, the values of
-c tv(1),...,tv(nv) should be left unchanged between subsequent
-c calls. if the computation mode iopt(1)=-1 is used,the values
-c tv(5),...tv(nv-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c u : real array of dimension at least (m).
-c v : real array of dimension at least (m).
-c on succesful exit, u(i),v(i) contains the co-ordinates of
-c the i-th data point with respect to the transformed rectan-
-c gular approximation domain, for i=1,2,...,m.
-c if the computation mode iopt(1)=1 is used the values of
-c u(i),v(i) should be left unchanged between subsequent calls.
-c c : real array of dimension at least (nuest-4)*(nvest-4).
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(u,v).
-c fp : real. unless ier=10, fp contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c wrk1 : real array of dimension (lwrk1). used as workspace.
-c if the computation mode iopt(1)=1 is used the value of
-c wrk1(1) should be left unchanged between subsequent calls.
-c on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the
-c values d(i)/max(d(i)),i=1,...,ncof=1+iopt(2)*(iopt(2)+3)/2+
-c (nv-7)*(nu-5-iopt(2)-iopt(3)) with d(i) the i-th diagonal el-
-c ement of the triangular matrix for calculating the b-spline
-c coefficients.it includes those elements whose square is < eps
-c which are treated as 0 in the case of rank deficiency(ier=-2)
-c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of
-c the array wrk1 as declared in the calling (sub)program.
-c lwrk1 must not be too small. let
-c k = nuest-7, l = nvest-7, p = 1+iopt(2)*(iopt(2)+3)/2,
-c q = k+2-iopt(2)-iopt(3) then
-c lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m
-c wrk2 : real array of dimension (lwrk2). used as workspace, but
-c only in the case a rank deficient system is encountered.
-c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of
-c the array wrk2 as declared in the calling (sub)program.
-c lwrk2 > 0 . a save upper bound for lwrk2 = (p+l*q+1)*(4*l+p)
-c +p+l*q where p,l,q are as above. if there are enough data
-c points, scattered uniformly over the approximation domain
-c and if the smoothing factor s is not too small, there is a
-c good chance that this extra workspace is not needed. a lot
-c of memory might therefore be saved by setting lwrk2=1.
-c (see also ier > 10)
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= m+(nuest-7)*(nvest-7).
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c spline (fp=0).
-c ier=-2 : normal return. the spline returned is the weighted least-
-c squares constrained polynomial . in this extreme case
-c fp gives the upper bound for the smoothing factor s.
-c ier<-2 : warning. the coefficients of the spline returned have been
-c computed as the minimal norm least-squares solution of a
-c (numerically) rank deficient system. (-ier) gives the rank.
-c especially if the rank deficiency which can be computed as
-c 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2)-iopt(3))+ier
-c is large the results may be inaccurate.
-c they could also seriously depend on the value of eps.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters nuest and
-c nvest.
-c probably causes : nuest or nvest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the weighted least-squares
-c polar spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small or badly chosen eps.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=4 : error. no more knots can be added because the dimension
-c of the spline 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2)
-c -iopt(3)) already exceeds the number of data points m.
-c probably causes : either s or m too small.
-c the approximation returned is the weighted least-squares
-c polar spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=5 : error. no more knots can be added because the additional
-c knot would (quasi) coincide with an old one.
-c probably causes : s too small or too large a weight to an
-c inaccurate data point.
-c the approximation returned is the weighted least-squares
-c polar spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt(1)<=1 , 0<=iopt(2)<=2 , 0<=iopt(3)<=1 ,
-c m>=4-iopt(2)-iopt(3) , nuest>=8 ,nvest >=8, 0<eps<1,
-c 0<=teta(i)<=pi, 0<=phi(i)<=2*pi, w(i)>0, i=1,...,m
-c lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m
-c kwrk >= m+(nuest-7)*(nvest-7)
-c if iopt(1)=-1:9<=nu<=nuest,9+iopt(2)*(iopt(2)+1)<=nv<=nvest
-c 0<tu(5)<tu(6)<...<tu(nu-4)<1
-c -pi<tv(5)<tv(6)<...<tv(nv-4)<pi
-c if iopt(1)>=0: s>=0
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c ier>10 : error. lwrk2 is too small, i.e. there is not enough work-
-c space for computing the minimal least-squares solution of
-c a rank deficient system of linear equations. ier gives the
-c requested value for lwrk2. there is no approximation re-
-c turned but, having saved the information contained in nu,
-c nv,tu,tv,wrk1,u,v and having adjusted the value of lwrk2
-c and the dimension of the array wrk2 accordingly, the user
-c can continue at the point the program was left, by calling
-c polar with iopt(1)=1.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the constrained weighted least-squares polynomial if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in z(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c polynomial and the corresponding upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximation shows more detail) to obtain closer fits.
-c to choose s very small is strongly discouraged. this considerably
-c increases computation time and memory requirements. it may also
-c cause rank-deficiency (ier<-2) and endager numerical stability.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt(1)=0.
-c if iopt(1)=1 the program will continue with the set of knots found
-c at the last call of the routine. this will save a lot of computation
-c time if polar is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. if the computation mode iopt(1)=1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt(1)=1,the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c polar once more with the selected value for s but now with iopt(1)=0
-c indeed, polar may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds nuest and
-c nvest. indeed, if at a certain stage in polar the number of knots
-c in one direction (say nu) has reached the value of its upper bound
-c (nuest), then from that moment on all subsequent knots are added
-c in the other (v) direction. this may indicate that the value of
-c nuest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c
-c other subroutines required:
-c fpback,fpbspl,fppola,fpdisc,fpgivs,fprank,fprati,fprota,fporde,
-c fprppo
-c
-c references:
-c dierckx p.: an algorithm for fitting data over a circle using tensor
-c product splines,j.comp.appl.maths 15 (1986) 161-173.
-c dierckx p.: an algorithm for fitting data on a circle using tensor
-c product splines, report tw68, dept. computer science,
-c k.u.leuven, 1984.
-c dierckx p.: curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : june 1984
-c latest update : march 1989
-c
-c ..
-c ..scalar arguments..
- real*8 s,eps,fp
- integer m,nuest,nvest,nu,nv,lwrk1,lwrk2,kwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),z(m),w(m),tu(nuest),tv(nvest),u(m),v(m),
- * c((nuest-4)*(nvest-4)),wrk1(lwrk1),wrk2(lwrk2)
- integer iopt(3),iwrk(kwrk)
-c ..user specified function
- real*8 rad
-c ..local scalars..
- real*8 tol,pi,dist,r,one
- integer i,ib1,ib3,ki,kn,kwest,la,lbu,lcc,lcs,lro,j
- * lbv,lco,lf,lff,lfp,lh,lq,lsu,lsv,lwest,maxit,ncest,ncc,nuu,
- * nvv,nreg,nrint,nu4,nv4,iopt1,iopt2,iopt3,ipar,nvmin
-c ..function references..
- real*8 datan2,sqrt
- external rad
-c ..subroutine references..
-c fppola
-c ..
-c set up constants
- one = 1d0
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid,control is immediately repassed to the calling program.
- ier = 10
- if(eps.le.0. .or. eps.ge.1.) go to 60
- iopt1 = iopt(1)
- if(iopt1.lt.(-1) .or. iopt1.gt.1) go to 60
- iopt2 = iopt(2)
- if(iopt2.lt.0 .or. iopt2.gt.2) go to 60
- iopt3 = iopt(3)
- if(iopt3.lt.0 .or. iopt3.gt.1) go to 60
- if(m.lt.(4-iopt2-iopt3)) go to 60
- if(nuest.lt.8 .or. nvest.lt.8) go to 60
- nu4 = nuest-4
- nv4 = nvest-4
- ncest = nu4*nv4
- nuu = nuest-7
- nvv = nvest-7
- ipar = 1+iopt2*(iopt2+3)/2
- ncc = ipar+nvv*(nuest-5-iopt2-iopt3)
- nrint = nuu+nvv
- nreg = nuu*nvv
- ib1 = 4*nvv
- ib3 = ib1+ipar
- lwest = ncc*(1+ib1+ib3)+2*nrint+ncest+m*8+ib3+5*nuest+12*nvest
- kwest = m+nreg
- if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 60
- if(iopt1.gt.0) go to 40
- do 10 i=1,m
- if(w(i).le.0.) go to 60
- dist = x(i)**2+y(i)**2
- u(i) = 0.
- v(i) = 0.
- if(dist.le.0.) go to 10
- v(i) = datan2(y(i),x(i))
- r = rad(v(i))
- if(r.le.0.) go to 60
- u(i) = sqrt(dist)/r
- if(u(i).gt.one) go to 60
- 10 continue
- if(iopt1.eq.0) go to 40
- nuu = nu-8
- if(nuu.lt.1 .or. nu.gt.nuest) go to 60
- tu(4) = 0.
- do 20 i=1,nuu
- j = i+4
- if(tu(j).le.tu(j-1) .or. tu(j).ge.one) go to 60
- 20 continue
- nvv = nv-8
- nvmin = 9+iopt2*(iopt2+1)
- if(nv.lt.nvmin .or. nv.gt.nvest) go to 60
- pi = datan2(0d0,-one)
- tv(4) = -pi
- do 30 i=1,nvv
- j = i+4
- if(tv(j).le.tv(j-1) .or. tv(j).ge.pi) go to 60
- 30 continue
- go to 50
- 40 if(s.lt.0.) go to 60
- 50 ier = 0
-c we partition the working space and determine the spline approximation
- kn = 1
- ki = kn+m
- lq = 2
- la = lq+ncc*ib3
- lf = la+ncc*ib1
- lff = lf+ncc
- lfp = lff+ncest
- lco = lfp+nrint
- lh = lco+nrint
- lbu = lh+ib3
- lbv = lbu+5*nuest
- lro = lbv+5*nvest
- lcc = lro+nvest
- lcs = lcc+nvest
- lsu = lcs+nvest*5
- lsv = lsu+m*4
- call fppola(iopt1,iopt2,iopt3,m,u,v,z,w,rad,s,nuest,nvest,eps,tol,
- *
- * maxit,ib1,ib3,ncest,ncc,nrint,nreg,nu,tu,nv,tv,c,fp,wrk1(1),
- * wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc),
- * wrk1(lcs),wrk1(la),wrk1(lq),wrk1(lbu),wrk1(lbv),wrk1(lsu),
- * wrk1(lsv),wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier)
- 60 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/profil.f
===================================================================
--- branches/Interpolate1D/fitpack/profil.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/profil.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,117 +0,0 @@
- subroutine profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier)
-c if iopt=0 subroutine profil calculates the b-spline coefficients of
-c the univariate spline f(y) = s(u,y) with s(x,y) a bivariate spline of
-c degrees kx and ky, given in the b-spline representation.
-c if iopt = 1 it calculates the b-spline coefficients of the univariate
-c spline g(x) = s(x,u)
-c
-c calling sequence:
-c call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier)
-c
-c input parameters:
-c iopt : integer flag, specifying whether the profile f(y) (iopt=0)
-c or the profile g(x) (iopt=1) must be determined.
-c tx : real array, length nx, which contains the position of the
-c knots in the x-direction.
-c nx : integer, giving the total number of knots in the x-direction
-c ty : real array, length ny, which contains the position of the
-c knots in the y-direction.
-c ny : integer, giving the total number of knots in the y-direction
-c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the
-c b-spline coefficients.
-c kx,ky : integer values, giving the degrees of the spline.
-c u : real value, specifying the requested profile.
-c tx(kx+1)<=u<=tx(nx-kx), if iopt=0.
-c ty(ky+1)<=u<=ty(ny-ky), if iopt=1.
-c nu : on entry nu must specify the dimension of the array cu.
-c nu >= ny if iopt=0, nu >= nx if iopt=1.
-c
-c output parameters:
-c cu : real array of dimension (nu).
-c on succesful exit this array contains the b-spline
-c ier : integer error flag
-c ier=0 : normal return
-c ier=10: invalid input data (see restrictions)
-c
-c restrictions:
-c if iopt=0 : tx(kx+1) <= u <= tx(nx-kx), nu >=ny.
-c if iopt=1 : ty(ky+1) <= u <= ty(ny-ky), nu >=nx.
-c
-c other subroutines required:
-c fpbspl
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer iopt,nx,ny,kx,ky,nu,ier
- real*8 u
-c ..array arguments..
- real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),cu(nu)
-c ..local scalars..
- integer i,j,kx1,ky1,l,l1,m,m0,nkx1,nky1
- real*8 sum
-c ..local array
- real*8 h(6)
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- kx1 = kx+1
- ky1 = ky+1
- nkx1 = nx-kx1
- nky1 = ny-ky1
- ier = 10
- if(iopt.ne.0) go to 200
- if(nu.lt.ny) go to 300
- if(u.lt.tx(kx1) .or. u.gt.tx(nkx1+1)) go to 300
-c the b-splinecoefficients of f(y) = s(u,y).
- ier = 0
- l = kx1
- l1 = l+1
- 110 if(u.lt.tx(l1) .or. l.eq.nkx1) go to 120
- l = l1
- l1 = l+1
- go to 110
- 120 call fpbspl(tx,nx,kx,u,l,h)
- m0 = (l-kx1)*nky1+1
- do 140 i=1,nky1
- m = m0
- sum = 0.
- do 130 j=1,kx1
- sum = sum+h(j)*c(m)
- m = m+nky1
- 130 continue
- cu(i) = sum
- m0 = m0+1
- 140 continue
- go to 300
- 200 if(nu.lt.nx) go to 300
- if(u.lt.ty(ky1) .or. u.gt.ty(nky1+1)) go to 300
-c the b-splinecoefficients of g(x) = s(x,u).
- ier = 0
- l = ky1
- l1 = l+1
- 210 if(u.lt.ty(l1) .or. l.eq.nky1) go to 220
- l = l1
- l1 = l+1
- go to 210
- 220 call fpbspl(ty,ny,ky,u,l,h)
- m0 = l-ky
- do 240 i=1,nkx1
- m = m0
- sum = 0.
- do 230 j=1,ky1
- sum = sum+h(j)*c(m)
- m = m+1
- 230 continue
- cu(i) = sum
- m0 = m0+nky1
- 240 continue
- 300 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/regrid.f
===================================================================
--- branches/Interpolate1D/fitpack/regrid.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/regrid.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,353 +0,0 @@
- subroutine regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,
- * nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c given the set of values z(i,j) on the rectangular grid (x(i),y(j)),
-c i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar-
-c iate spline approximation s(x,y) of degrees kx and ky on the rect-
-c angle xb <= x <= xe, yb <= y <= ye.
-c if iopt = -1 regrid calculates the least-squares spline according
-c to a given set of knots.
-c if iopt >= 0 the total numbers nx and ny of these knots and their
-c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic-
-c ally by the routine. the smoothness of s(x,y) is then achieved by
-c minimalizing the discontinuity jumps in the derivatives of s(x,y)
-c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1).
-c the amounth of smoothness is determined by the condition that f(p) =
-c sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative
-c constant, called the smoothing factor.
-c the fit is given in the b-spline representation (b-spline coefficients
-c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval-
-c uated by means of subroutine bispev.
-c
-c calling sequence:
-c call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
-c * nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a least-
-c squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1)
-c must be determined.
-c if iopt=0 the routine will start with an initial set of knots
-c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i=
-c 1,...,ky+1. if iopt=1 the routine will continue with the set
-c of knots found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately pre-
-c ceded by another call with iopt=1 or iopt=0 and
-c s.ne.0.
-c unchanged on exit.
-c mx : integer. on entry mx must specify the number of grid points
-c along the x-axis. mx > kx . unchanged on exit.
-c x : real array of dimension at least (mx). before entry, x(i)
-c must be set to the x-co-ordinate of the i-th grid point
-c along the x-axis, for i=1,2,...,mx. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c my : integer. on entry my must specify the number of grid points
-c along the y-axis. my > ky . unchanged on exit.
-c y : real array of dimension at least (my). before entry, y(j)
-c must be set to the y-co-ordinate of the j-th grid point
-c along the y-axis, for j=1,2,...,my. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c z : real array of dimension at least (mx*my).
-c before entry, z(my*(i-1)+j) must be set to the data value at
-c the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my.
-c unchanged on exit.
-c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound-
-c yb,ye aries of the rectangular approximation domain.
-c xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my.
-c unchanged on exit.
-c kx,ky : integer values. on entry kx and ky must specify the degrees
-c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic
-c (kx=ky=3) splines. unchanged on exit.
-c s : real. on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c nxest : integer. unchanged on exit.
-c nyest : integer. unchanged on exit.
-c on entry, nxest and nyest must specify an upper bound for the
-c number of knots required in the x- and y-directions respect.
-c these numbers will also determine the storage space needed by
-c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1).
-c in most practical situation nxest = mx/2, nyest=my/2, will
-c be sufficient. always large enough are nxest=mx+kx+1, nyest=
-c my+ky+1, the number of knots needed for interpolation (s=0).
-c see also further comments.
-c nx : integer.
-c unless ier=10 (in case iopt >=0), nx will contain the total
-c number of knots with respect to the x-variable, of the spline
-c approximation returned. if the computation mode iopt=1 is
-c used, the value of nx should be left unchanged between sub-
-c sequent calls.
-c in case iopt=-1, the value of nx should be specified on entry
-c tx : real array of dimension nmax.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the x-variable, i.e. the position of
-c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the
-c position of the additional knots tx(1)=...=tx(kx+1)=xb and
-c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat.
-c if the computation mode iopt=1 is used, the values of tx(1),
-c ...,tx(nx) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values tx(kx+2),
-c ...tx(nx-kx-1) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c ny : integer.
-c unless ier=10 (in case iopt >=0), ny will contain the total
-c number of knots with respect to the y-variable, of the spline
-c approximation returned. if the computation mode iopt=1 is
-c used, the value of ny should be left unchanged between sub-
-c sequent calls.
-c in case iopt=-1, the value of ny should be specified on entry
-c ty : real array of dimension nmax.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the y-variable, i.e. the position of
-c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the
-c position of the additional knots ty(1)=...=ty(ky+1)=yb and
-c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat.
-c if the computation mode iopt=1 is used, the values of ty(1),
-c ...,ty(ny) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values ty(ky+2),
-c ...ty(ny-ky-1) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1).
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(x,y)
-c fp : real. unless ier=10, fp contains the sum of squared
-c residuals of the spline approximation returned.
-c wrk : real array of dimension (lwrk). used as workspace.
-c if the computation mode iopt=1 is used the values of wrk(1),
-c ...,wrk(4) should be left unchanged between subsequent calls.
-c lwrk : integer. on entry lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.
-c lwrk must not be too small.
-c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+
-c my*(ky+1) +u
-c where u is the larger of my and nxest.
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c if the computation mode iopt=1 is used the values of iwrk(1),
-c ...,iwrk(3) should be left unchanged between subsequent calls
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= 3+mx+my+nxest+nyest.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c spline (fp=0).
-c ier=-2 : normal return. the spline returned is the least-squares
-c polynomial of degrees kx and ky. in this extreme case fp
-c gives the upper bound for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters nxest and
-c nyest.
-c probably causes : nxest or nyest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the least-squares spline
-c according to the current set of knots. the parameter fp
-c gives the corresponding sum of squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2,
-c nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest,
-c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+
-c my*(ky+1) +max(my,nxest),
-c xb<=x(i-1)<x(i)<=xe,i=2,..,mx,yb<=y(j-1)<y(j)<=ye,j=2,..,my
-c if iopt=-1: 2*kx+2<=nx<=min(nxest,mx+kx+1)
-c xb<tx(kx+2)<tx(kx+3)<...<tx(nx-kx-1)<xe
-c 2*ky+2<=ny<=min(nyest,my+ky+1)
-c yb<ty(ky+2)<ty(ky+3)<...<ty(ny-ky-1)<ye
-c the schoenberg-whitney conditions, i.e. there must
-c be subset of grid co-ordinates xx(p) and yy(q) such
-c that tx(p) < xx(p) < tx(p+kx+1) ,p=1,...,nx-kx-1
-c ty(q) < yy(q) < ty(q+ky+1) ,q=1,...,ny-ky-1
-c if iopt>=0: s>=0
-c if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c regrid does not allow individual weighting of the data-values.
-c so, if these were determined to widely different accuracies, then
-c perhaps the general data set routine surfit should rather be used
-c in spite of efficiency.
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the least-squares polynomial (degrees kx,ky) if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the accuracy of the data values.
-c if the user has an idea of the statistical errors on the data, he
-c can also find a proper estimate for s. for, by assuming that, if he
-c specifies the right s, regrid will return a spline s(x,y) which
-c exactly reproduces the function underlying the data he can evaluate
-c the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s
-c for example, if he knows that the statistical errors on his z(i,j)-
-c values is not greater than 0.1, he may expect that a good s should
-c have a value not larger than mx*my*(0.1)**2.
-c if nothing is known about the statistical error in z(i,j), s must
-c be determined by trial and error, taking account of the comments
-c above. the best is then to start with a very large value of s (to
-c determine the least-squares polynomial and the corresponding upper
-c bound fp0 for s) and then to progressively decrease the value of s
-c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
-c and more carefully as the approximation shows more detail) to
-c obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if regrid is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. if the computation mode iopt=1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c regrid once more with the selected value for s but now with iopt=0.
-c indeed, regrid may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds nxest and
-c nyest. indeed, if at a certain stage in regrid the number of knots
-c in one direction (say nx) has reached the value of its upper bound
-c (nxest), then from that moment on all subsequent knots are added
-c in the other (y) direction. this may indicate that the value of
-c nxest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c for example, by setting nxest=2*kx+2 (the lowest allowable value for
-c nxest), the user can indicate that he wants an approximation which
-c is a simple polynomial of degree kx in the variable x.
-c
-c other subroutines required:
-c fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec,
-c fpknot
-c
-c references:
-c dierckx p. : a fast algorithm for smoothing data on a rectangular
-c grid while using spline functions, siam j.numer.anal.
-c 19 (1982) 1286-1304.
-c dierckx p. : a fast algorithm for smoothing data on a rectangular
-c grid while using spline functions, report tw53, dept.
-c computer science,k.u.leuven, 1980.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1989
-c
-c ..
-c ..scalar arguments..
- real*8 xb,xe,yb,ye,s,fp
- integer iopt,mx,my,kx,ky,nxest,nyest,nx,ny,lwrk,kwrk,ier
-c ..array arguments..
- real*8 x(mx),y(my),z(mx*my),tx(nxest),ty(nyest),
- * c((nxest-kx-1)*(nyest-ky-1)),wrk(lwrk)
- integer iwrk(kwrk)
-c ..local scalars..
- real*8 tol
- integer i,j,jwrk,kndx,kndy,knrx,knry,kwest,kx1,kx2,ky1,ky2,
- * lfpx,lfpy,lwest,lww,maxit,nc,nminx,nminy,mz
-c ..function references..
- integer max0
-c ..subroutine references..
-c fpregr,fpchec
-c ..
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(kx.le.0 .or. kx.gt.5) go to 70
- kx1 = kx+1
- kx2 = kx1+1
- if(ky.le.0 .or. ky.gt.5) go to 70
- ky1 = ky+1
- ky2 = ky1+1
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 70
- nminx = 2*kx1
- if(mx.lt.kx1 .or. nxest.lt.nminx) go to 70
- nminy = 2*ky1
- if(my.lt.ky1 .or. nyest.lt.nminy) go to 70
- mz = mx*my
- nc = (nxest-kx1)*(nyest-ky1)
- lwest = 4+nxest*(my+2*kx2+1)+nyest*(2*ky2+1)+mx*kx1+
- * my*ky1+max0(nxest,my)
- kwest = 3+mx+my+nxest+nyest
- if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 70
- if(xb.gt.x(1) .or. xe.lt.x(mx)) go to 70
- do 10 i=2,mx
- if(x(i-1).ge.x(i)) go to 70
- 10 continue
- if(yb.gt.y(1) .or. ye.lt.y(my)) go to 70
- do 20 i=2,my
- if(y(i-1).ge.y(i)) go to 70
- 20 continue
- if(iopt.ge.0) go to 50
- if(nx.lt.nminx .or. nx.gt.nxest) go to 70
- j = nx
- do 30 i=1,kx1
- tx(i) = xb
- tx(j) = xe
- j = j-1
- 30 continue
- call fpchec(x,mx,tx,nx,kx,ier)
- if(ier.ne.0) go to 70
- if(ny.lt.nminy .or. ny.gt.nyest) go to 70
- j = ny
- do 40 i=1,ky1
- ty(i) = yb
- ty(j) = ye
- j = j-1
- 40 continue
- call fpchec(y,my,ty,ny,ky,ier)
- if (ier.eq.0) go to 60
- go to 70
- 50 if(s.lt.0.) go to 70
- if(s.eq.0. .and. (nxest.lt.(mx+kx1) .or. nyest.lt.(my+ky1)) )
- * go to 70
- ier = 0
-c we partition the working space and determine the spline approximation
- 60 lfpx = 5
- lfpy = lfpx+nxest
- lww = lfpy+nyest
- jwrk = lwrk-4-nxest-nyest
- knrx = 4
- knry = knrx+mx
- kndx = knry+my
- kndy = kndx+nxest
- call fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
- * tol,maxit,nc,nx,tx,ny,ty,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),
- * wrk(lfpx),wrk(lfpy),iwrk(1),iwrk(2),iwrk(3),iwrk(knrx),
- * iwrk(knry),iwrk(kndx),iwrk(kndy),wrk(lww),jwrk,ier)
- 70 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/spalde.f
===================================================================
--- branches/Interpolate1D/fitpack/spalde.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/spalde.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,73 +0,0 @@
- subroutine spalde(t,n,c,k1,x,d,ier)
-c subroutine spalde evaluates at a point x all the derivatives
-c (j-1)
-c d(j) = s (x) , j=1,2,...,k1
-c of a spline s(x) of order k1 (degree k=k1-1), given in its b-spline
-c representation.
-c
-c calling sequence:
-c call spalde(t,n,c,k1,x,d,ier)
-c
-c input parameters:
-c t : array,length n, which contains the position of the knots.
-c n : integer, giving the total number of knots of s(x).
-c c : array,length n, which contains the b-spline coefficients.
-c k1 : integer, giving the order of s(x) (order=degree+1)
-c x : real, which contains the point where the derivatives must
-c be evaluated.
-c
-c output parameters:
-c d : array,length k1, containing the derivative values of s(x).
-c ier : error flag
-c ier = 0 : normal return
-c ier =10 : invalid input data (see restrictions)
-c
-c restrictions:
-c t(k1) <= x <= t(n-k1+1)
-c
-c further comments:
-c if x coincides with a knot, right derivatives are computed
-c ( left derivatives if x = t(n-k1+1) ).
-c
-c other subroutines required: fpader.
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer n,k1,ier
- real*8 x
-c ..array arguments..
- real*8 t(n),c(n),d(k1)
-c ..local scalars..
- integer l,nk1
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- nk1 = n-k1
- if(x.lt.t(k1) .or. x.gt.t(nk1+1)) go to 300
-c search for knot interval t(l) <= x < t(l+1)
- l = k1
- 100 if(x.lt.t(l+1) .or. l.eq.nk1) go to 200
- l = l+1
- go to 100
- 200 if(t(l).ge.t(l+1)) go to 300
- ier = 0
-c calculate the derivatives.
- call fpader(t,n,c,k1,x,l,d)
- 300 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/spgrid.f
===================================================================
--- branches/Interpolate1D/fitpack/spgrid.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/spgrid.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,501 +0,0 @@
- subroutine spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,
- * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c given the function values r(i,j) on the latitude-longitude grid
-c (u(i),v(j)), i=1,...,mu ; j=1,...,mv , spgrid determines a smooth
-c bicubic spline approximation on the rectangular domain 0<=u<=pi,
-c vb<=v<=ve (vb = v(1), ve=vb+2*pi).
-c this approximation s(u,v) will satisfy the properties
-c
-c (1) s(0,v) = s(0,0) = dr(1)
-c
-c d s(0,v) d s(0,0) d s(0,pi/2)
-c (2) -------- = cos(v)* -------- + sin(v)* -----------
-c d u d u d u
-c
-c = cos(v)*dr(2)+sin(v)*dr(3)
-c vb <= v <= ve
-c (3) s(pi,v) = s(pi,0) = dr(4)
-c
-c d s(pi,v) d s(pi,0) d s(pi,pi/2)
-c (4) -------- = cos(v)* --------- + sin(v)* ------------
-c d u d u d u
-c
-c = cos(v)*dr(5)+sin(v)*dr(6)
-c
-c and will be periodic in the variable v, i.e.
-c
-c j j
-c d s(u,vb) d s(u,ve)
-c (5) --------- = --------- 0 <=u<= pi , j=0,1,2
-c j j
-c d v d v
-c
-c the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu;
-c tv(j),j=1,2,...,nv, is chosen automatically by the routine. the
-c smoothness of s(u,v) is achieved by minimalizing the discontinuity
-c jumps of the derivatives of the spline at the knots. the amount of
-c smoothness of s(u,v) is determined by the condition that
-c fp=sumi=1,mu(sumj=1,mv((r(i,j)-s(u(i),v(j)))**2))+(r0-s(0,v))**2
-c + (r1-s(pi,v))**2 <= s, with s a given non-negative constant.
-c the fit s(u,v) is given in its b-spline representation and can be
-c evaluated by means of routine bispev
-c
-c calling sequence:
-c call spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,nu,tu,
-c * ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer array of dimension 3, specifying different options.
-c unchanged on exit.
-c iopt(1):on entry iopt(1) must specify whether a least-squares spline
-c (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be
-c determined.
-c if iopt(1)=0 the routine will start with an initial set of
-c knots tu(i)=0,tu(i+4)=pi,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi,
-c i=1,...,8.
-c if iopt(1)=1 the routine will continue with the set of knots
-c found at the last call of the routine.
-c attention: a call with iopt(1)=1 must always be immediately
-c preceded by another call with iopt(1) = 1 or iopt(1) = 0.
-c iopt(2):on entry iopt(2) must specify the requested order of conti-
-c nuity at the pole u=0.
-c if iopt(2)=0 only condition (1) must be fulfilled and
-c if iopt(2)=1 conditions (1)+(2) must be fulfilled.
-c iopt(3):on entry iopt(3) must specify the requested order of conti-
-c nuity at the pole u=pi.
-c if iopt(3)=0 only condition (3) must be fulfilled and
-c if iopt(3)=1 conditions (3)+(4) must be fulfilled.
-c ider : integer array of dimension 4, specifying different options.
-c unchanged on exit.
-c ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not
-c (ider(1)=-1) there is a data value r0 at the pole u=0.
-c if ider(1)=1, r0 will be considered to be the right function
-c value, and it will be fitted exactly (s(0,v)=r0).
-c if ider(1)=0, r0 will be considered to be a data value just
-c like the other data values r(i,j).
-c ider(2):on entry ider(2) must specify whether (ider(2)=1) or not
-c (ider(2)=0) the approximation has vanishing derivatives
-c dr(2) and dr(3) at the pole u=0 (in case iopt(2)=1)
-c ider(3):on entry ider(3) must specify whether (ider(3)=0 or 1) or not
-c (ider(3)=-1) there is a data value r1 at the pole u=pi.
-c if ider(3)=1, r1 will be considered to be the right function
-c value, and it will be fitted exactly (s(pi,v)=r1).
-c if ider(3)=0, r1 will be considered to be a data value just
-c like the other data values r(i,j).
-c ider(4):on entry ider(4) must specify whether (ider(4)=1) or not
-c (ider(4)=0) the approximation has vanishing derivatives
-c dr(5) and dr(6) at the pole u=pi (in case iopt(3)=1)
-c mu : integer. on entry mu must specify the number of grid points
-c along the u-axis. unchanged on exit.
-c mu >= 1, mu >=mumin=4-i0-i1-ider(2)-ider(4) with
-c i0=min(1,ider(1)+1), i1=min(1,ider(3)+1)
-c u : real array of dimension at least (mu). before entry, u(i)
-c must be set to the u-co-ordinate of the i-th grid point
-c along the u-axis, for i=1,2,...,mu. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c 0 < u(i) < pi.
-c mv : integer. on entry mv must specify the number of grid points
-c along the v-axis. mv > 3 . unchanged on exit.
-c v : real array of dimension at least (mv). before entry, v(j)
-c must be set to the v-co-ordinate of the j-th grid point
-c along the v-axis, for j=1,2,...,mv. these values must be
-c supplied in strictly ascending order. unchanged on exit.
-c -pi <= v(1) < pi , v(mv) < v(1)+2*pi.
-c r : real array of dimension at least (mu*mv).
-c before entry, r(mv*(i-1)+j) must be set to the data value at
-c the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv.
-c unchanged on exit.
-c r0 : real value. on entry (if ider(1) >=0 ) r0 must specify the
-c data value at the pole u=0. unchanged on exit.
-c r1 : real value. on entry (if ider(1) >=0 ) r1 must specify the
-c data value at the pole u=pi. unchanged on exit.
-c s : real. on entry (if iopt(1)>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c nuest : integer. unchanged on exit.
-c nvest : integer. unchanged on exit.
-c on entry, nuest and nvest must specify an upper bound for the
-c number of knots required in the u- and v-directions respect.
-c these numbers will also determine the storage space needed by
-c the routine. nuest >= 8, nvest >= 8.
-c in most practical situation nuest = mu/2, nvest=mv/2, will
-c be sufficient. always large enough are nuest=mu+6+iopt(2)+
-c iopt(3), nvest = mv+7, the number of knots needed for
-c interpolation (s=0). see also further comments.
-c nu : integer.
-c unless ier=10 (in case iopt(1)>=0), nu will contain the total
-c number of knots with respect to the u-variable, of the spline
-c approximation returned. if the computation mode iopt(1)=1 is
-c used, the value of nu should be left unchanged between sub-
-c sequent calls. in case iopt(1)=-1, the value of nu should be
-c specified on entry.
-c tu : real array of dimension at least (nuest).
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the u-variable, i.e. the position of
-c the interior knots tu(5),...,tu(nu-4) as well as the position
-c of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...=
-c tu(nu)=pi needed for the b-spline representation.
-c if the computation mode iopt(1)=1 is used,the values of tu(1)
-c ...,tu(nu) should be left unchanged between subsequent calls.
-c if the computation mode iopt(1)=-1 is used, the values tu(5),
-c ...tu(nu-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c nv : integer.
-c unless ier=10 (in case iopt(1)>=0), nv will contain the total
-c number of knots with respect to the v-variable, of the spline
-c approximation returned. if the computation mode iopt(1)=1 is
-c used, the value of nv should be left unchanged between sub-
-c sequent calls. in case iopt(1) = -1, the value of nv should
-c be specified on entry.
-c tv : real array of dimension at least (nvest).
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the v-variable, i.e. the position of
-c the interior knots tv(5),...,tv(nv-4) as well as the position
-c of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
-c tv(nv) needed for the b-spline representation.
-c if the computation mode iopt(1)=1 is used,the values of tv(1)
-c ...,tv(nv) should be left unchanged between subsequent calls.
-c if the computation mode iopt(1)=-1 is used, the values tv(5),
-c ...tv(nv-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c c : real array of dimension at least (nuest-4)*(nvest-4).
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(u,v)
-c fp : real. unless ier=10, fp contains the sum of squared
-c residuals of the spline approximation returned.
-c wrk : real array of dimension (lwrk). used as workspace.
-c if the computation mode iopt(1)=1 is used the values of
-c wrk(1),..,wrk(12) should be left unchanged between subsequent
-c calls.
-c lwrk : integer. on entry lwrk must specify the actual dimension of
-c the array wrk as declared in the calling (sub)program.
-c lwrk must not be too small.
-c lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+q
-c where q is the larger of (mv+nvest) and nuest.
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c if the computation mode iopt(1)=1 is used the values of
-c iwrk(1),.,iwrk(5) should be left unchanged between subsequent
-c calls.
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= 5+mu+mv+nuest+nvest.
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c spline (fp=0).
-c ier=-2 : normal return. the spline returned is the least-squares
-c constrained polynomial. in this extreme case fp gives the
-c upper bound for the smoothing factor s.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters nuest and
-c nvest.
-c probably causes : nuest or nvest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the least-squares spline
-c according to the current set of knots. the parameter fp
-c gives the corresponding sum of squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small.
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c sum of squared residuals does not satisfy the condition
-c abs(fp-s)/s < tol.
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1,
-c -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0.
-c -1<=ider(3)<=1, 0<=ider(4)<=1, ider(4)=0 if iopt(3)=0.
-c mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8,
-c kwrk>=5+mu+mv+nuest+nvest,
-c lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+
-c max(nuest,mv+nvest)
-c 0< u(i-1)<u(i)< pi,i=2,..,mu,
-c -pi<=v(1)< pi, v(1)<v(i-1)<v(i)<v(1)+2*pi, i=3,...,mv
-c if iopt(1)=-1: 8<=nu<=min(nuest,mu+6+iopt(2)+iopt(3))
-c 0<tu(5)<tu(6)<...<tu(nu-4)< pi
-c 8<=nv<=min(nvest,mv+7)
-c v(1)<tv(5)<tv(6)<...<tv(nv-4)<v(1)+2*pi
-c the schoenberg-whitney conditions, i.e. there must
-c be subset of grid co-ordinates uu(p) and vv(q) such
-c that tu(p) < uu(p) < tu(p+4) ,p=1,...,nu-4
-c (iopt(2)=1 and iopt(3)=1 also count for a uu-value
-c tv(q) < vv(q) < tv(q+4) ,q=1,...,nv-4
-c (vv(q) is either a value v(j) or v(j)+2*pi)
-c if iopt(1)>=0: s>=0
-c if s=0: nuest>=mu+6+iopt(2)+iopt(3), nvest>=mv+7
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c
-c further comments:
-c spgrid does not allow individual weighting of the data-values.
-c so, if these were determined to widely different accuracies, then
-c perhaps the general data set routine sphere should rather be used
-c in spite of efficiency.
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the constrained least-squares polynomial(degrees 3,0)if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the accuracy of the data values.
-c if the user has an idea of the statistical errors on the data, he
-c can also find a proper estimate for s. for, by assuming that, if he
-c specifies the right s, spgrid will return a spline s(u,v) which
-c exactly reproduces the function underlying the data he can evaluate
-c the sum((r(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s
-c for example, if he knows that the statistical errors on his r(i,j)-
-c values is not greater than 0.1, he may expect that a good s should
-c have a value not larger than mu*mv*(0.1)**2.
-c if nothing is known about the statistical error in r(i,j), s must
-c be determined by trial and error, taking account of the comments
-c above. the best is then to start with a very large value of s (to
-c determine the least-squares polynomial and the corresponding upper
-c bound fp0 for s) and then to progressively decrease the value of s
-c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
-c and more carefully as the approximation shows more detail) to
-c obtain closer fits.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt(1)=0.
-c if iopt(1) = 1 the program will continue with the knots found at
-c the last call of the routine. this will save a lot of computation
-c time if spgrid is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. if the computation mode iopt(1) = 1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt(1)=1,the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c spgrid once more with the chosen value for s but now with iopt(1)=0.
-c indeed, spgrid may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds nuest and
-c nvest. indeed, if at a certain stage in spgrid the number of knots
-c in one direction (say nu) has reached the value of its upper bound
-c (nuest), then from that moment on all subsequent knots are added
-c in the other (v) direction. this may indicate that the value of
-c nuest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c for example, by setting nuest=8 (the lowest allowable value for
-c nuest), the user can indicate that he wants an approximation which
-c is a simple cubic polynomial in the variable u.
-c
-c other subroutines required:
-c fpspgr,fpchec,fpchep,fpknot,fpopsp,fprati,fpgrsp,fpsysy,fpback,
-c fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota
-c
-c references:
-c dierckx p. : fast algorithms for smoothing data over a disc or a
-c sphere using tensor product splines, in "algorithms
-c for approximation", ed. j.c.mason and m.g.cox,
-c clarendon press oxford, 1987, pp. 51-65
-c dierckx p. : fast algorithms for smoothing data over a disc or a
-c sphere using tensor product splines, report tw73, dept.
-c computer science,k.u.leuven, 1985.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : july 1985
-c latest update : march 1989
-c
-c ..
-c ..scalar arguments..
- real*8 r0,r1,s,fp
- integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier
-c ..array arguments..
- integer iopt(3),ider(4),iwrk(kwrk)
- real*8 u(mu),v(mv),r(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest),
- * tv(nvest),wrk(lwrk)
-c ..local scalars..
- real*8 per,pi,tol,uu,ve,rmax,rmin,one,half,rn,rb,re
- integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l,
- * ldr,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc
-c ..function references..
- real*8 datan2
- integer max0
-c ..subroutine references..
-c fpchec,fpchep,fpspgr
-c ..
-c set constants
- one = 1d0
- half = 0.5e0
- pi = datan2(0d0,-one)
- per = pi+pi
- ve = v(1)+per
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations, a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- ier = 10
- if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200
- if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200
- if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200
- if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200
- if(ider(2).lt.0 .or. ider(2).gt.1) go to 200
- if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200
- if(ider(3).lt.(-1) .or. ider(3).gt.1) go to 200
- if(ider(4).lt.0 .or. ider(4).gt.1) go to 200
- if(ider(4).eq.1 .and. iopt(3).eq.0) go to 200
- mumin = 4
- if(ider(1).ge.0) mumin = mumin-1
- if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1
- if(ider(3).ge.0) mumin = mumin-1
- if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1
- if(mumin.eq.0) mumin = 1
- if(mu.lt.mumin .or. mv.lt.4) go to 200
- if(nuest.lt.8 .or. nvest.lt.8) go to 200
- m = mu*mv
- nc = (nuest-4)*(nvest-4)
- lwest = 12+nuest*(mv+nvest+3)+24*nvest+4*mu+8*mv+
- * max0(nuest,mv+nvest)
- kwest = 5+mu+mv+nuest+nvest
- if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200
- if(u(1).le.0. .or. u(mu).ge.pi) go to 200
- if(mu.eq.1) go to 30
- do 20 i=2,mu
- if(u(i-1).ge.u(i)) go to 200
- 20 continue
- 30 if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200
- if(v(mv).ge.v(1)+per) go to 200
- do 40 i=2,mv
- if(v(i-1).ge.v(i)) go to 200
- 40 continue
- if(iopt(1).gt.0) go to 140
-c if not given, we compute an estimate for r0.
- rn = mv
- if(ider(1).lt.0) go to 45
- rb = r0
- go to 55
- 45 rb = 0.
- do 50 i=1,mv
- rb = rb+r(i)
- 50 continue
- rb = rb/rn
-c if not given, we compute an estimate for r1.
- 55 if(ider(3).lt.0) go to 60
- re = r1
- go to 70
- 60 re = 0.
- j = m
- do 65 i=1,mv
- re = re+r(j)
- j = j-1
- 65 continue
- re = re/rn
-c we determine the range of r-values.
- 70 rmin = rb
- rmax = re
- do 80 i=1,m
- if(r(i).lt.rmin) rmin = r(i)
- if(r(i).gt.rmax) rmax = r(i)
- 80 continue
- wrk(5) = rb
- wrk(6) = 0.
- wrk(7) = 0.
- wrk(8) = re
- wrk(9) = 0.
- wrk(10) = 0.
- wrk(11) = rmax -rmin
- wrk(12) = wrk(11)
- iwrk(4) = mu
- iwrk(5) = mu
- if(iopt(1).eq.0) go to 140
- if(nu.lt.8 .or. nu.gt.nuest) go to 200
- if(nv.lt.11 .or. nv.gt.nvest) go to 200
- j = nu
- do 90 i=1,4
- tu(i) = 0.
- tu(j) = pi
- j = j-1
- 90 continue
- l = 13
- wrk(l) = 0.
- if(iopt(2).eq.0) go to 100
- l = l+1
- uu = u(1)
- if(uu.gt.tu(5)) uu = tu(5)
- wrk(l) = uu*half
- 100 do 110 i=1,mu
- l = l+1
- wrk(l) = u(i)
- 110 continue
- if(iopt(3).eq.0) go to 120
- l = l+1
- uu = u(mu)
- if(uu.lt.tu(nu-4)) uu = tu(nu-4)
- wrk(l) = uu+(pi-uu)*half
- 120 l = l+1
- wrk(l) = pi
- muu = l-12
- call fpchec(wrk(13),muu,tu,nu,3,ier)
- if(ier.ne.0) go to 200
- j1 = 4
- tv(j1) = v(1)
- i1 = nv-3
- tv(i1) = ve
- j2 = j1
- i2 = i1
- do 130 i=1,3
- i1 = i1+1
- i2 = i2-1
- j1 = j1+1
- j2 = j2-1
- tv(j2) = tv(i2)-per
- tv(i1) = tv(j1)+per
- 130 continue
- l = 13
- do 135 i=1,mv
- wrk(l) = v(i)
- l = l+1
- 135 continue
- wrk(l) = ve
- call fpchep(wrk(13),mv+1,tv,nv,3,ier)
- if (ier.eq.0) go to 150
- go to 200
- 140 if(s.lt.0.) go to 200
- if(s.eq.0. .and. (nuest.lt.(mu+6+iopt(2)+iopt(3)) .or.
- * nvest.lt.(mv+7)) ) go to 200
-c we partition the working space and determine the spline approximation
- 150 ldr = 5
- lfpu = 13
- lfpv = lfpu+nuest
- lww = lfpv+nvest
- jwrk = lwrk-12-nuest-nvest
- knru = 6
- knrv = knru+mu
- kndu = knrv+mv
- kndv = kndu+nuest
- call fpspgr(iopt,ider,u,mu,v,mv,r,m,rb,re,s,nuest,nvest,tol,maxit,
- *
- * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu),
- * wrk(lfpv),wrk(ldr),wrk(11),iwrk(1),iwrk(2),iwrk(3),iwrk(4),
- * iwrk(5),iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),
- * jwrk,ier)
- 200 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/sphere.f
===================================================================
--- branches/Interpolate1D/fitpack/sphere.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/sphere.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,404 +0,0 @@
- subroutine sphere(iopt,m,teta,phi,r,w,s,ntest,npest,eps,
- * nt,tt,np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
-c subroutine sphere determines a smooth bicubic spherical spline
-c approximation s(teta,phi), 0 <= teta <= pi ; 0 <= phi <= 2*pi
-c to a given set of data points (teta(i),phi(i),r(i)),i=1,2,...,m.
-c such a spline has the following specific properties
-c
-c (1) s(0,phi) = constant 0 <=phi<= 2*pi.
-c
-c (2) s(pi,phi) = constant 0 <=phi<= 2*pi
-c
-c j j
-c d s(teta,0) d s(teta,2*pi)
-c (3) ----------- = ------------ 0 <=teta<=pi, j=0,1,2
-c j j
-c d phi d phi
-c
-c d s(0,phi) d s(0,0) d s(0,pi/2)
-c (4) ---------- = -------- *cos(phi) + ----------- *sin(phi)
-c d teta d teta d teta
-c
-c d s(pi,phi) d s(pi,0) d s(pi,pi/2)
-c (5) ----------- = ---------*cos(phi) + ------------*sin(phi)
-c d teta d teta d teta
-c
-c if iopt =-1 sphere calculates a weighted least-squares spherical
-c spline according to a given set of knots in teta- and phi- direction.
-c if iopt >=0, the number of knots in each direction and their position
-c tt(j),j=1,2,...,nt ; tp(j),j=1,2,...,np are chosen automatically by
-c the routine. the smoothness of s(teta,phi) is then achieved by mini-
-c malizing the discontinuity jumps of the derivatives of the spline
-c at the knots. the amount of smoothness of s(teta,phi) is determined
-c by the condition that fp = sum((w(i)*(r(i)-s(teta(i),phi(i))))**2)
-c be <= s, with s a given non-negative constant.
-c the spherical spline is given in the standard b-spline representation
-c of bicubic splines and can be evaluated by means of subroutine bispev
-c
-c calling sequence:
-c call sphere(iopt,m,teta,phi,r,w,s,ntest,npest,eps,
-c * nt,tt,np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares spherical spline (iopt=-1) or a smoothing
-c spherical spline (iopt=0 or 1) must be determined.
-c if iopt=0 the routine will start with an initial set of knots
-c tt(i)=0,tt(i+4)=pi,i=1,...,4;tp(i)=0,tp(i+4)=2*pi,i=1,...,4.
-c if iopt=1 the routine will continue with the set of knots
-c found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately pre-
-c ceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m >= 2. unchanged on exit.
-c teta : real array of dimension at least (m).
-c phi : real array of dimension at least (m).
-c r : real array of dimension at least (m).
-c before entry,teta(i),phi(i),r(i) must be set to the spherical
-c co-ordinates of the i-th data point, for i=1,...,m.the order
-c of the data points is immaterial. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i) must
-c be set to the i-th value in the set of weights. the w(i) must
-c be strictly positive. unchanged on exit.
-c s : real. on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c ntest : integer. unchanged on exit.
-c npest : integer. unchanged on exit.
-c on entry, ntest and npest must specify an upper bound for the
-c number of knots required in the teta- and phi-directions.
-c these numbers will also determine the storage space needed by
-c the routine. ntest >= 8, npest >= 8.
-c in most practical situation ntest = npest = 8+sqrt(m/2) will
-c be sufficient. see also further comments.
-c eps : real.
-c on entry, eps must specify a threshold for determining the
-c effective rank of an over-determined linear system of equat-
-c ions. 0 < eps < 1. if the number of decimal digits in the
-c computer representation of a real number is q, then 10**(-q)
-c is a suitable value for eps in most practical applications.
-c unchanged on exit.
-c nt : integer.
-c unless ier=10 (in case iopt >=0), nt will contain the total
-c number of knots with respect to the teta-variable, of the
-c spline approximation returned. if the computation mode iopt=1
-c is used, the value of nt should be left unchanged between
-c subsequent calls.
-c in case iopt=-1, the value of nt should be specified on entry
-c tt : real array of dimension at least ntest.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the teta-variable, i.e. the position
-c of the interior knots tt(5),...,tt(nt-4) as well as the
-c position of the additional knots tt(1)=...=tt(4)=0 and
-c tt(nt-3)=...=tt(nt)=pi needed for the b-spline representation
-c if the computation mode iopt=1 is used, the values of tt(1),
-c ...,tt(nt) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values tt(5),
-c ...tt(nt-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c np : integer.
-c unless ier=10 (in case iopt >=0), np will contain the total
-c number of knots with respect to the phi-variable, of the
-c spline approximation returned. if the computation mode iopt=1
-c is used, the value of np should be left unchanged between
-c subsequent calls.
-c in case iopt=-1, the value of np (>=9) should be specified
-c on entry.
-c tp : real array of dimension at least npest.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the phi-variable, i.e. the position of
-c the interior knots tp(5),...,tp(np-4) as well as the position
-c of the additional knots tp(1),...,tp(4) and tp(np-3),...,
-c tp(np) needed for the b-spline representation.
-c if the computation mode iopt=1 is used, the values of tp(1),
-c ...,tp(np) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values tp(5),
-c ...tp(np-4) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c c : real array of dimension at least (ntest-4)*(npest-4).
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(teta,phi).
-c fp : real. unless ier=10, fp contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c wrk1 : real array of dimension (lwrk1). used as workspace.
-c if the computation mode iopt=1 is used the value of wrk1(1)
-c should be left unchanged between subsequent calls.
-c on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the
-c values d(i)/max(d(i)),i=1,...,ncof=6+(np-7)*(nt-8)
-c with d(i) the i-th diagonal element of the reduced triangular
-c matrix for calculating the b-spline coefficients. it includes
-c those elements whose square is less than eps,which are treat-
-c ed as 0 in the case of presumed rank deficiency (ier<-2).
-c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of
-c the array wrk1 as declared in the calling (sub)program.
-c lwrk1 must not be too small. let
-c u = ntest-7, v = npest-7, then
-c lwrk1 >= 185+52*v+10*u+14*u*v+8*(u-1)*v**2+8*m
-c wrk2 : real array of dimension (lwrk2). used as workspace, but
-c only in the case a rank deficient system is encountered.
-c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of
-c the array wrk2 as declared in the calling (sub)program.
-c lwrk2 > 0 . a save upper bound for lwrk2 = 48+21*v+7*u*v+
-c 4*(u-1)*v**2 where u,v are as above. if there are enough data
-c points, scattered uniformly over the approximation domain
-c and if the smoothing factor s is not too small, there is a
-c good chance that this extra workspace is not needed. a lot
-c of memory might therefore be saved by setting lwrk2=1.
-c (see also ier > 10)
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= m+(ntest-7)*(npest-7).
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is a spherical
-c interpolating spline (fp=0).
-c ier=-2 : normal return. the spline returned is the weighted least-
-c squares constrained polynomial . in this extreme case
-c fp gives the upper bound for the smoothing factor s.
-c ier<-2 : warning. the coefficients of the spline returned have been
-c computed as the minimal norm least-squares solution of a
-c (numerically) rank deficient system. (-ier) gives the rank.
-c especially if the rank deficiency which can be computed as
-c 6+(nt-8)*(np-7)+ier, is large the results may be inaccurate
-c they could also seriously depend on the value of eps.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters ntest and
-c npest.
-c probably causes : ntest or npest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the weighted least-squares
-c spherical spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small or badly chosen eps.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=4 : error. no more knots can be added because the dimension
-c of the spherical spline 6+(nt-8)*(np-7) already exceeds
-c the number of data points m.
-c probably causes : either s or m too small.
-c the approximation returned is the weighted least-squares
-c spherical spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=5 : error. no more knots can be added because the additional
-c knot would (quasi) coincide with an old one.
-c probably causes : s too small or too large a weight to an
-c inaccurate data point.
-c the approximation returned is the weighted least-squares
-c spherical spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, m>=2, ntest>=8 ,npest >=8, 0<eps<1,
-c 0<=teta(i)<=pi, 0<=phi(i)<=2*pi, w(i)>0, i=1,...,m
-c lwrk1 >= 185+52*v+10*u+14*u*v+8*(u-1)*v**2+8*m
-c kwrk >= m+(ntest-7)*(npest-7)
-c if iopt=-1: 8<=nt<=ntest , 9<=np<=npest
-c 0<tt(5)<tt(6)<...<tt(nt-4)<pi
-c 0<tp(5)<tp(6)<...<tp(np-4)<2*pi
-c if iopt>=0: s>=0
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c ier>10 : error. lwrk2 is too small, i.e. there is not enough work-
-c space for computing the minimal least-squares solution of
-c a rank deficient system of linear equations. ier gives the
-c requested value for lwrk2. there is no approximation re-
-c turned but, having saved the information contained in nt,
-c np,tt,tp,wrk1, and having adjusted the value of lwrk2 and
-c the dimension of the array wrk2 accordingly, the user can
-c continue at the point the program was left, by calling
-c sphere with iopt=1.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the constrained weighted least-squares polynomial if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c r(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in r(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c polynomial and the corresponding upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximation shows more detail) to obtain closer fits.
-c to choose s very small is strongly discouraged. this considerably
-c increases computation time and memory requirements. it may also
-c cause rank-deficiency (ier<-2) and endager numerical stability.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if sphere is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. if the computation mode iopt=1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c sphere once more with the selected value for s but now with iopt=0.
-c indeed, sphere may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds ntest and
-c npest. indeed, if at a certain stage in sphere the number of knots
-c in one direction (say nt) has reached the value of its upper bound
-c (ntest), then from that moment on all subsequent knots are added
-c in the other (phi) direction. this may indicate that the value of
-c ntest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c for example, by setting ntest=8 (the lowest allowable value for
-c ntest), the user can indicate that he wants an approximation which
-c is a cubic polynomial in the variable teta.
-c
-c other subroutines required:
-c fpback,fpbspl,fpsphe,fpdisc,fpgivs,fprank,fprati,fprota,fporde,
-c fprpsp
-c
-c references:
-c dierckx p. : algorithms for smoothing data on the sphere with tensor
-c product splines, computing 32 (1984) 319-342.
-c dierckx p. : algorithms for smoothing data on the sphere with tensor
-c product splines, report tw62, dept. computer science,
-c k.u.leuven, 1983.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : july 1983
-c latest update : march 1989
-c
-c ..
-c ..scalar arguments..
- real*8 s,eps,fp
- integer iopt,m,ntest,npest,nt,np,lwrk1,lwrk2,kwrk,ier
-c ..array arguments..
- real*8 teta(m),phi(m),r(m),w(m),tt(ntest),tp(npest),
- * c((ntest-4)*(npest-4)),wrk1(lwrk1),wrk2(lwrk2)
- integer iwrk(kwrk)
-c ..local scalars..
- real*8 tol,pi,pi2,one
- integer i,ib1,ib3,ki,kn,kwest,la,lbt,lcc,lcs,lro,j
- * lbp,lco,lf,lff,lfp,lh,lq,lst,lsp,lwest,maxit,ncest,ncc,ntt,
- * npp,nreg,nrint,ncof,nt4,np4
-c ..function references..
- real*8 atan
-c ..subroutine references..
-c fpsphe
-c ..
-c set constants
- one = 0.1e+01
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid,control is immediately repassed to the calling program.
- ier = 10
- if(eps.le.0. .or. eps.ge.1.) go to 80
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 80
- if(m.lt.2) go to 80
- if(ntest.lt.8 .or. npest.lt.8) go to 80
- nt4 = ntest-4
- np4 = npest-4
- ncest = nt4*np4
- ntt = ntest-7
- npp = npest-7
- ncc = 6+npp*(ntt-1)
- nrint = ntt+npp
- nreg = ntt*npp
- ncof = 6+3*npp
- ib1 = 4*npp
- ib3 = ib1+3
- if(ncof.gt.ib1) ib1 = ncof
- if(ncof.gt.ib3) ib3 = ncof
- lwest = 185+52*npp+10*ntt+14*ntt*npp+8*(m+(ntt-1)*npp**2)
- kwest = m+nreg
- if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 80
- if(iopt.gt.0) go to 60
- pi = atan(one)*4
- pi2 = pi+pi
- do 20 i=1,m
- if(w(i).le.0.) go to 80
- if(teta(i).lt.0. .or. teta(i).gt.pi) go to 80
- if(phi(i) .lt.0. .or. phi(i).gt.pi2) go to 80
- 20 continue
- if(iopt.eq.0) go to 60
- ntt = nt-8
- if(ntt.lt.0 .or. nt.gt.ntest) go to 80
- if(ntt.eq.0) go to 40
- tt(4) = 0.
- do 30 i=1,ntt
- j = i+4
- if(tt(j).le.tt(j-1) .or. tt(j).ge.pi) go to 80
- 30 continue
- 40 npp = np-8
- if(npp.lt.1 .or. np.gt.npest) go to 80
- tp(4) = 0.
- do 50 i=1,npp
- j = i+4
- if(tp(j).le.tp(j-1) .or. tp(j).ge.pi2) go to 80
- 50 continue
- go to 70
- 60 if(s.lt.0.) go to 80
- 70 ier = 0
-c we partition the working space and determine the spline approximation
- kn = 1
- ki = kn+m
- lq = 2
- la = lq+ncc*ib3
- lf = la+ncc*ib1
- lff = lf+ncc
- lfp = lff+ncest
- lco = lfp+nrint
- lh = lco+nrint
- lbt = lh+ib3
- lbp = lbt+5*ntest
- lro = lbp+5*npest
- lcc = lro+npest
- lcs = lcc+npest
- lst = lcs+npest
- lsp = lst+m*4
- call fpsphe(iopt,m,teta,phi,r,w,s,ntest,npest,eps,tol,maxit,
- * ib1,ib3,ncest,ncc,nrint,nreg,nt,tt,np,tp,c,fp,wrk1(1),wrk1(lfp),
- * wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc),wrk1(lcs),
- * wrk1(la),wrk1(lq),wrk1(lbt),wrk1(lbp),wrk1(lst),wrk1(lsp),
- * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier)
- 80 return
- end
-
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/splder.f
===================================================================
--- branches/Interpolate1D/fitpack/splder.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/splder.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,162 +0,0 @@
- subroutine splder(t,n,c,k,nu,x,y,m,wrk,ier)
-c subroutine splder evaluates in a number of points x(i),i=1,2,...,m
-c the derivative of order nu of a spline s(x) of degree k,given in
-c its b-spline representation.
-c
-c calling sequence:
-c call splder(t,n,c,k,nu,x,y,m,wrk,ier)
-c
-c input parameters:
-c t : array,length n, which contains the position of the knots.
-c n : integer, giving the total number of knots of s(x).
-c c : array,length n, which contains the b-spline coefficients.
-c k : integer, giving the degree of s(x).
-c nu : integer, specifying the order of the derivative. 0<=nu<=k
-c x : array,length m, which contains the points where the deriv-
-c ative of s(x) must be evaluated.
-c m : integer, giving the number of points where the derivative
-c of s(x) must be evaluated
-c wrk : real array of dimension n. used as working space.
-c
-c output parameters:
-c y : array,length m, giving the value of the derivative of s(x)
-c at the different points.
-c ier : error flag
-c ier = 0 : normal return
-c ier =10 : invalid input data (see restrictions)
-c
-c restrictions:
-c 0 <= nu <= k
-c m >= 1
-c t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1.
-c
-c other subroutines required: fpbspl
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c++ pearu: 13 aug 20003
-c++ - disabled cliping x values to interval [min(t),max(t)]
-c++ - removed the restriction of the orderness of x values
-c++ - fixed initialization of sp to double precision value
-c
-c ..scalar arguments..
- integer n,k,nu,m,ier
-c ..array arguments..
- real*8 t(n),c(n),x(m),y(m),wrk(n)
-c ..local scalars..
- integer i,j,kk,k1,k2,l,ll,l1,l2,nk1,nk2,nn
- real*8 ak,arg,fac,sp,tb,te
-c++..
- integer k3
-c..++
-c ..local arrays ..
- real*8 h(6)
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- if(nu.lt.0 .or. nu.gt.k) go to 200
-c-- if(m-1) 200,30,10
-c++..
- if(m.lt.1) go to 200
-c..++
-c-- 10 do 20 i=2,m
-c-- if(x(i).lt.x(i-1)) go to 200
-c-- 20 continue
- 30 ier = 0
-c fetch tb and te, the boundaries of the approximation interval.
- k1 = k+1
- k3 = k1+1
- nk1 = n-k1
- tb = t(k1)
- te = t(nk1+1)
-c the derivative of order nu of a spline of degree k is a spline of
-c degree k-nu,the b-spline coefficients wrk(i) of which can be found
-c using the recurrence scheme of de boor.
- l = 1
- kk = k
- nn = n
- do 40 i=1,nk1
- wrk(i) = c(i)
- 40 continue
- if(nu.eq.0) go to 100
- nk2 = nk1
- do 60 j=1,nu
- ak = kk
- nk2 = nk2-1
- l1 = l
- do 50 i=1,nk2
- l1 = l1+1
- l2 = l1+kk
- fac = t(l2)-t(l1)
- if(fac.le.0.) go to 50
- wrk(i) = ak*(wrk(i+1)-wrk(i))/fac
- 50 continue
- l = l+1
- kk = kk-1
- 60 continue
- if(kk.ne.0) go to 100
-c if nu=k the derivative is a piecewise constant function
- j = 1
- do 90 i=1,m
- arg = x(i)
-c++..
- 65 if(arg.ge.t(l) .or. l+1.eq.k2) go to 70
- l1 = l
- l = l-1
- j = j-1
- go to 65
-c..++
- 70 if(arg.lt.t(l+1) .or. l.eq.nk1) go to 80
- l = l+1
- j = j+1
- go to 70
- 80 y(i) = wrk(j)
- 90 continue
- go to 200
- 100 l = k1
- l1 = l+1
- k2 = k1-nu
-c main loop for the different points.
- do 180 i=1,m
-c fetch a new x-value arg.
- arg = x(i)
-c-- if(arg.lt.tb) arg = tb
-c-- if(arg.gt.te) arg = te
-c search for knot interval t(l) <= arg < t(l+1)
-c++..
- 135 if(arg.ge.t(l) .or. l1.eq.k3) go to 140
- l1 = l
- l = l-1
- go to 135
-c..++
- 140 if(arg.lt.t(l1) .or. l.eq.nk1) go to 150
- l = l1
- l1 = l+1
- go to 140
-c evaluate the non-zero b-splines of degree k-nu at arg.
- 150 call fpbspl(t,n,kk,arg,l,h)
-c find the value of the derivative at x=arg.
- sp = 0.0d0
- ll = l-k1
- do 160 j=1,k2
- ll = ll+1
- sp = sp+wrk(ll)*h(j)
- 160 continue
- y(i) = sp
- 180 continue
- 200 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/splev.f
===================================================================
--- branches/Interpolate1D/fitpack/splev.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/splev.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,115 +0,0 @@
- subroutine splev(t,n,c,k,x,y,m,ier)
-c subroutine splev evaluates in a number of points x(i),i=1,2,...,m
-c a spline s(x) of degree k, given in its b-spline representation.
-c
-c calling sequence:
-c call splev(t,n,c,k,x,y,m,ier)
-c
-c input parameters:
-c t : array,length n, which contains the position of the knots.
-c n : integer, giving the total number of knots of s(x).
-c c : array,length n, which contains the b-spline coefficients.
-c k : integer, giving the degree of s(x).
-c x : array,length m, which contains the points where s(x) must
-c be evaluated.
-c m : integer, giving the number of points where s(x) must be
-c evaluated.
-c
-c output parameter:
-c y : array,length m, giving the value of s(x) at the different
-c points.
-c ier : error flag
-c ier = 0 : normal return
-c ier =10 : invalid input data (see restrictions)
-c
-c restrictions:
-c m >= 1
-c-- t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1.
-c
-c other subroutines required: fpbspl.
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c++ pearu: 11 aug 2003
-c++ - disabled cliping x values to interval [min(t),max(t)]
-c++ - removed the restriction of the orderness of x values
-c++ - fixed initialization of sp to double precision value
-c
-c ..scalar arguments..
- integer n,k,m,ier
-c ..array arguments..
- real*8 t(n),c(n),x(m),y(m)
-c ..local scalars..
- integer i,j,k1,l,ll,l1,nk1
-c++..
- integer k2
-c..++
- real*8 arg,sp,tb,te
-c ..local array..
- real*8 h(20)
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
-c-- if(m-1) 100,30,10
-c++..
- if(m.lt.1) go to 100
-c..++
-c-- 10 do 20 i=2,m
-c-- if(x(i).lt.x(i-1)) go to 100
-c-- 20 continue
- 30 ier = 0
-c fetch tb and te, the boundaries of the approximation interval.
- k1 = k+1
-c++..
- k2 = k1+1
-c..++
- nk1 = n-k1
- tb = t(k1)
- te = t(nk1+1)
- l = k1
- l1 = l+1
-c main loop for the different points.
- do 80 i=1,m
-c fetch a new x-value arg.
- arg = x(i)
-c-- if(arg.lt.tb) arg = tb
-c-- if(arg.gt.te) arg = te
-c search for knot interval t(l) <= arg < t(l+1)
-c++..
- 35 if(arg.ge.t(l) .or. l1.eq.k2) go to 40
- l1 = l
- l = l-1
- go to 35
-c..++
- 40 if(arg.lt.t(l1) .or. l.eq.nk1) go to 50
- l = l1
- l1 = l+1
- go to 40
-c evaluate the non-zero b-splines at arg.
- 50 call fpbspl(t,n,k,arg,l,h)
-c find the value of s(x) at x=arg.
- sp = 0.0d0
- ll = l-k1
- do 60 j=1,k1
- ll = ll+1
- sp = sp+c(ll)*h(j)
- 60 continue
- y(i) = sp
- 80 continue
- 100 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/splint.f
===================================================================
--- branches/Interpolate1D/fitpack/splint.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/splint.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,58 +0,0 @@
- real*8 function splint(t,n,c,k,a,b,wrk)
-c function splint calculates the integral of a spline function s(x)
-c of degree k, which is given in its normalized b-spline representation
-c
-c calling sequence:
-c aint = splint(t,n,c,k,a,b,wrk)
-c
-c input parameters:
-c t : array,length n,which contains the position of the knots
-c of s(x).
-c n : integer, giving the total number of knots of s(x).
-c c : array,length n, containing the b-spline coefficients.
-c k : integer, giving the degree of s(x).
-c a,b : real values, containing the end points of the integration
-c interval. s(x) is considered to be identically zero outside
-c the interval (t(k+1),t(n-k)).
-c
-c output parameter:
-c aint : real, containing the integral of s(x) between a and b.
-c wrk : real array, length n. used as working space
-c on output, wrk will contain the integrals of the normalized
-c b-splines defined on the set of knots.
-c
-c other subroutines required: fpintb.
-c
-c references :
-c gaffney p.w. : the calculation of indefinite integrals of b-splines
-c j. inst. maths applics 17 (1976) 37-41.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- real*8 a,b
- integer n,k
-c ..array arguments..
- real*8 t(n),c(n),wrk(n)
-c ..local scalars..
- integer i,nk1
-c ..
- nk1 = n-k-1
-c calculate the integrals wrk(i) of the normalized b-splines
-c ni,k+1(x), i=1,2,...nk1.
- call fpintb(t,n,wrk,nk1,a,b)
-c calculate the integral of s(x).
- splint = 0.0d0
- do 10 i=1,nk1
- splint = splint+c(i)*wrk(i)
- 10 continue
- return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/sproot.f
===================================================================
--- branches/Interpolate1D/fitpack/sproot.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/sproot.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,183 +0,0 @@
- subroutine sproot(t,n,c,zero,mest,m,ier)
-c subroutine sproot finds the zeros of a cubic spline s(x),which is
-c given in its normalized b-spline representation.
-c
-c calling sequence:
-c call sproot(t,n,c,zero,mest,m,ier)
-c
-c input parameters:
-c t : real array,length n, containing the knots of s(x).
-c n : integer, containing the number of knots. n>=8
-c c : real array,length n, containing the b-spline coefficients.
-c mest : integer, specifying the dimension of array zero.
-c
-c output parameters:
-c zero : real array,lenth mest, containing the zeros of s(x).
-c m : integer,giving the number of zeros.
-c ier : error flag:
-c ier = 0: normal return.
-c ier = 1: the number of zeros exceeds mest.
-c ier =10: invalid input data (see restrictions).
-c
-c other subroutines required: fpcuro
-c
-c restrictions:
-c 1) n>= 8.
-c 2) t(4) < t(5) < ... < t(n-4) < t(n-3).
-c t(1) <= t(2) <= t(3) <= t(4)
-c t(n-3) <= t(n-2) <= t(n-1) <= t(n)
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- integer n,mest,m,ier
-c ..array arguments..
- real*8 t(n),c(n),zero(mest)
-c ..local scalars..
- integer i,j,j1,l,n4
- real*8 ah,a0,a1,a2,a3,bh,b0,b1,c1,c2,c3,c4,c5,d4,d5,h1,h2,
- * three,two,t1,t2,t3,t4,t5,zz
- logical z0,z1,z2,z3,z4,nz0,nz1,nz2,nz3,nz4
-c ..local array..
- real*8 y(3)
-c ..
-c set some constants
- two = 0.2d+01
- three = 0.3d+01
-c before starting computations a data check is made. if the input data
-c are invalid, control is immediately repassed to the calling program.
- n4 = n-4
- ier = 10
- if(n.lt.8) go to 800
- j = n
- do 10 i=1,3
- if(t(i).gt.t(i+1)) go to 800
- if(t(j).lt.t(j-1)) go to 800
- j = j-1
- 10 continue
- do 20 i=4,n4
- if(t(i).ge.t(i+1)) go to 800
- 20 continue
-c the problem considered reduces to finding the zeros of the cubic
-c polynomials pl(x) which define the cubic spline in each knot
-c interval t(l)<=x<=t(l+1). a zero of pl(x) is also a zero of s(x) on
-c the condition that it belongs to the knot interval.
-c the cubic polynomial pl(x) is determined by computing s(t(l)),
-c s'(t(l)),s(t(l+1)) and s'(t(l+1)). in fact we only have to compute
-c s(t(l+1)) and s'(t(l+1)); because of the continuity conditions of
-c splines and their derivatives, the value of s(t(l)) and s'(t(l))
-c is already known from the foregoing knot interval.
- ier = 0
-c evaluate some constants for the first knot interval
- h1 = t(4)-t(3)
- h2 = t(5)-t(4)
- t1 = t(4)-t(2)
- t2 = t(5)-t(3)
- t3 = t(6)-t(4)
- t4 = t(5)-t(2)
- t5 = t(6)-t(3)
-c calculate a0 = s(t(4)) and ah = s'(t(4)).
- c1 = c(1)
- c2 = c(2)
- c3 = c(3)
- c4 = (c2-c1)/t4
- c5 = (c3-c2)/t5
- d4 = (h2*c1+t1*c2)/t4
- d5 = (t3*c2+h1*c3)/t5
- a0 = (h2*d4+h1*d5)/t2
- ah = three*(h2*c4+h1*c5)/t2
- z1 = .true.
- if(ah.lt.0.0d0) z1 = .false.
- nz1 = .not.z1
- m = 0
-c main loop for the different knot intervals.
- do 300 l=4,n4
-c evaluate some constants for the knot interval t(l) <= x <= t(l+1).
- h1 = h2
- h2 = t(l+2)-t(l+1)
- t1 = t2
- t2 = t3
- t3 = t(l+3)-t(l+1)
- t4 = t5
- t5 = t(l+3)-t(l)
-c find a0 = s(t(l)), ah = s'(t(l)), b0 = s(t(l+1)) and bh = s'(t(l+1)).
- c1 = c2
- c2 = c3
- c3 = c(l)
- c4 = c5
- c5 = (c3-c2)/t5
- d4 = (h2*c1+t1*c2)/t4
- d5 = (h1*c3+t3*c2)/t5
- b0 = (h2*d4+h1*d5)/t2
- bh = three*(h2*c4+h1*c5)/t2
-c calculate the coefficients a0,a1,a2 and a3 of the cubic polynomial
-c pl(x) = ql(y) = a0+a1*y+a2*y**2+a3*y**3 ; y = (x-t(l))/(t(l+1)-t(l)).
- a1 = ah*h1
- b1 = bh*h1
- a2 = three*(b0-a0)-b1-two*a1
- a3 = two*(a0-b0)+b1+a1
-c test whether or not pl(x) could have a zero in the range
-c t(l) <= x <= t(l+1).
- z3 = .true.
- if(b1.lt.0.0d0) z3 = .false.
- nz3 = .not.z3
- if(a0*b0.le.0.0d0) go to 100
- z0 = .true.
- if(a0.lt.0.0d0) z0 = .false.
- nz0 = .not.z0
- z2 = .true.
- if(a2.lt.0.) z2 = .false.
- nz2 = .not.z2
- z4 = .true.
- if(3.0d0*a3+a2.lt.0.0d0) z4 = .false.
- nz4 = .not.z4
- if(.not.((z0.and.(nz1.and.(z3.or.z2.and.nz4).or.nz2.and.
- * z3.and.z4).or.nz0.and.(z1.and.(nz3.or.nz2.and.z4).or.z2.and.
- * nz3.and.nz4))))go to 200
-c find the zeros of ql(y).
- 100 call fpcuro(a3,a2,a1,a0,y,j)
- if(j.eq.0) go to 200
-c find which zeros of pl(x) are zeros of s(x).
- do 150 i=1,j
- if(y(i).lt.0.0d0 .or. y(i).gt.1.0d0) go to 150
-c test whether the number of zeros of s(x) exceeds mest.
- if(m.ge.mest) go to 700
- m = m+1
- zero(m) = t(l)+h1*y(i)
- 150 continue
- 200 a0 = b0
- ah = bh
- z1 = z3
- nz1 = nz3
- 300 continue
-c the zeros of s(x) are arranged in increasing order.
- if(m.lt.2) go to 800
- do 400 i=2,m
- j = i
- 350 j1 = j-1
- if(j1.eq.0) go to 400
- if(zero(j).ge.zero(j1)) go to 400
- zz = zero(j)
- zero(j) = zero(j1)
- zero(j1) = zz
- j = j1
- go to 350
- 400 continue
- j = m
- m = 1
- do 500 i=2,j
- if(zero(i).eq.zero(m)) go to 500
- m = m+1
- zero(m) = zero(i)
- 500 continue
- go to 800
- 700 ier = 1
- 800 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/surev.f
===================================================================
--- branches/Interpolate1D/fitpack/surev.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/surev.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,106 +0,0 @@
- subroutine surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,mf,wrk,lwrk,
- * iwrk,kwrk,ier)
-c subroutine surev evaluates on a grid (u(i),v(j)),i=1,...,mu; j=1,...
-c ,mv a bicubic spline surface of dimension idim, given in the
-c b-spline representation.
-c
-c calling sequence:
-c call surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,mf,wrk,lwrk,
-c * iwrk,kwrk,ier)
-c
-c input parameters:
-c idim : integer, specifying the dimension of the spline surface.
-c tu : real array, length nu, which contains the position of the
-c knots in the u-direction.
-c nu : integer, giving the total number of knots in the u-direction
-c tv : real array, length nv, which contains the position of the
-c knots in the v-direction.
-c nv : integer, giving the total number of knots in the v-direction
-c c : real array, length (nu-4)*(nv-4)*idim, which contains the
-c b-spline coefficients.
-c u : real array of dimension (mu).
-c before entry u(i) must be set to the u co-ordinate of the
-c i-th grid point along the u-axis.
-c tu(4)<=u(i-1)<=u(i)<=tu(nu-3), i=2,...,mu.
-c mu : on entry mu must specify the number of grid points along
-c the u-axis. mu >=1.
-c v : real array of dimension (mv).
-c before entry v(j) must be set to the v co-ordinate of the
-c j-th grid point along the v-axis.
-c tv(4)<=v(j-1)<=v(j)<=tv(nv-3), j=2,...,mv.
-c mv : on entry mv must specify the number of grid points along
-c the v-axis. mv >=1.
-c mf : on entry, mf must specify the dimension of the array f.
-c mf >= mu*mv*idim
-c wrk : real array of dimension lwrk. used as workspace.
-c lwrk : integer, specifying the dimension of wrk.
-c lwrk >= 4*(mu+mv)
-c iwrk : integer array of dimension kwrk. used as workspace.
-c kwrk : integer, specifying the dimension of iwrk. kwrk >= mu+mv.
-c
-c output parameters:
-c f : real array of dimension (mf).
-c on succesful exit f(mu*mv*(l-1)+mv*(i-1)+j) contains the
-c l-th co-ordinate of the bicubic spline surface at the
-c point (u(i),v(j)),l=1,...,idim,i=1,...,mu;j=1,...,mv.
-c ier : integer error flag
-c ier=0 : normal return
-c ier=10: invalid input data (see restrictions)
-c
-c restrictions:
-c mu >=1, mv >=1, lwrk>=4*(mu+mv), kwrk>=mu+mv , mf>=mu*mv*idim
-c tu(4) <= u(i-1) <= u(i) <= tu(nu-3), i=2,...,mu
-c tv(4) <= v(j-1) <= v(j) <= tv(nv-3), j=2,...,mv
-c
-c other subroutines required:
-c fpsuev,fpbspl
-c
-c references :
-c de boor c : on calculating with b-splines, j. approximation theory
-c 6 (1972) 50-62.
-c cox m.g. : the numerical evaluation of b-splines, j. inst. maths
-c applics 10 (1972) 134-149.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author :
-c p.dierckx
-c dept. computer science, k.u.leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c latest update : march 1987
-c
-c ..scalar arguments..
- integer idim,nu,nv,mu,mv,mf,lwrk,kwrk,ier
-c ..array arguments..
- integer iwrk(kwrk)
- real*8 tu(nu),tv(nv),c((nu-4)*(nv-4)*idim),u(mu),v(mv),f(mf),
- * wrk(lwrk)
-c ..local scalars..
- integer i,muv
-c ..
-c before starting computations a data check is made. if the input data
-c are invalid control is immediately repassed to the calling program.
- ier = 10
- if(mf.lt.mu*mv*idim) go to 100
- muv = mu+mv
- if(lwrk.lt.4*muv) go to 100
- if(kwrk.lt.muv) go to 100
- if (mu.lt.1) go to 100
- if (mu.eq.1) go to 30
- go to 10
- 10 do 20 i=2,mu
- if(u(i).lt.u(i-1)) go to 100
- 20 continue
- 30 if (mv.lt.1) go to 100
- if (mv.eq.1) go to 60
- go to 40
- 40 do 50 i=2,mv
- if(v(i).lt.v(i-1)) go to 100
- 50 continue
- 60 ier = 0
- call fpsuev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,wrk(1),wrk(4*mu+1),
- * iwrk(1),iwrk(mu+1))
- 100 return
- end
Deleted: branches/Interpolate1D/extensions/fitpack/fitpack/surfit.f
===================================================================
--- branches/Interpolate1D/fitpack/surfit.f 2008-07-31 19:09:00 UTC (rev 4587)
+++ branches/Interpolate1D/extensions/fitpack/fitpack/surfit.f 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,412 +0,0 @@
- subroutine surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
- * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
-c given the set of data points (x(i),y(i),z(i)) and the set of positive
-c numbers w(i),i=1,...,m, subroutine surfit determines a smooth bivar-
-c iate spline approximation s(x,y) of degrees kx and ky on the rect-
-c angle xb <= x <= xe, yb <= y <= ye.
-c if iopt = -1 surfit calculates the weighted least-squares spline
-c according to a given set of knots.
-c if iopt >= 0 the total numbers nx and ny of these knots and their
-c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic-
-c ally by the routine. the smoothness of s(x,y) is then achieved by
-c minimalizing the discontinuity jumps in the derivatives of s(x,y)
-c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1).
-c the amounth of smoothness is determined by the condition that f(p) =
-c sum ((w(i)*(z(i)-s(x(i),y(i))))**2) be <= s, with s a given non-neg-
-c ative constant, called the smoothing factor.
-c the fit is given in the b-spline representation (b-spline coefficients
-c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval-
-c uated by means of subroutine bispev.
-c
-c calling sequence:
-c call surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
-c * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
-c
-c parameters:
-c iopt : integer flag. on entry iopt must specify whether a weighted
-c least-squares spline (iopt=-1) or a smoothing spline (iopt=0
-c or 1) must be determined.
-c if iopt=0 the routine will start with an initial set of knots
-c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i=
-c 1,...,ky+1. if iopt=1 the routine will continue with the set
-c of knots found at the last call of the routine.
-c attention: a call with iopt=1 must always be immediately pre-
-c ceded by another call with iopt=1 or iopt=0.
-c unchanged on exit.
-c m : integer. on entry m must specify the number of data points.
-c m >= (kx+1)*(ky+1). unchanged on exit.
-c x : real array of dimension at least (m).
-c y : real array of dimension at least (m).
-c z : real array of dimension at least (m).
-c before entry, x(i),y(i),z(i) must be set to the co-ordinates
-c of the i-th data point, for i=1,...,m. the order of the data
-c points is immaterial. unchanged on exit.
-c w : real array of dimension at least (m). before entry, w(i) must
-c be set to the i-th value in the set of weights. the w(i) must
-c be strictly positive. unchanged on exit.
-c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound-
-c yb,ye aries of the rectangular approximation domain.
-c xb<=x(i)<=xe,yb<=y(i)<=ye,i=1,...,m. unchanged on exit.
-c kx,ky : integer values. on entry kx and ky must specify the degrees
-c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic
-c (kx=ky=3) splines. unchanged on exit.
-c s : real. on entry (in case iopt>=0) s must specify the smoothing
-c factor. s >=0. unchanged on exit.
-c for advice on the choice of s see further comments
-c nxest : integer. unchanged on exit.
-c nyest : integer. unchanged on exit.
-c on entry, nxest and nyest must specify an upper bound for the
-c number of knots required in the x- and y-directions respect.
-c these numbers will also determine the storage space needed by
-c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1).
-c in most practical situation nxest = kx+1+sqrt(m/2), nyest =
-c ky+1+sqrt(m/2) will be sufficient. see also further comments.
-c nmax : integer. on entry nmax must specify the actual dimension of
-c the arrays tx and ty. nmax >= nxest, nmax >=nyest.
-c unchanged on exit.
-c eps : real.
-c on entry, eps must specify a threshold for determining the
-c effective rank of an over-determined linear system of equat-
-c ions. 0 < eps < 1. if the number of decimal digits in the
-c computer representation of a real number is q, then 10**(-q)
-c is a suitable value for eps in most practical applications.
-c unchanged on exit.
-c nx : integer.
-c unless ier=10 (in case iopt >=0), nx will contain the total
-c number of knots with respect to the x-variable, of the spline
-c approximation returned. if the computation mode iopt=1 is
-c used, the value of nx should be left unchanged between sub-
-c sequent calls.
-c in case iopt=-1, the value of nx should be specified on entry
-c tx : real array of dimension nmax.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the x-variable, i.e. the position of
-c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the
-c position of the additional knots tx(1)=...=tx(kx+1)=xb and
-c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat.
-c if the computation mode iopt=1 is used, the values of tx(1),
-c ...,tx(nx) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values tx(kx+2),
-c ...tx(nx-kx-1) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c ny : integer.
-c unless ier=10 (in case iopt >=0), ny will contain the total
-c number of knots with respect to the y-variable, of the spline
-c approximation returned. if the computation mode iopt=1 is
-c used, the value of ny should be left unchanged between sub-
-c sequent calls.
-c in case iopt=-1, the value of ny should be specified on entry
-c ty : real array of dimension nmax.
-c on succesful exit, this array will contain the knots of the
-c spline with respect to the y-variable, i.e. the position of
-c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the
-c position of the additional knots ty(1)=...=ty(ky+1)=yb and
-c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat.
-c if the computation mode iopt=1 is used, the values of ty(1),
-c ...,ty(ny) should be left unchanged between subsequent calls.
-c if the computation mode iopt=-1 is used, the values ty(ky+2),
-c ...ty(ny-ky-1) must be supplied by the user, before entry.
-c see also the restrictions (ier=10).
-c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1).
-c on succesful exit, c contains the coefficients of the spline
-c approximation s(x,y)
-c fp : real. unless ier=10, fp contains the weighted sum of
-c squared residuals of the spline approximation returned.
-c wrk1 : real array of dimension (lwrk1). used as workspace.
-c if the computation mode iopt=1 is used the value of wrk1(1)
-c should be left unchanged between subsequent calls.
-c on exit wrk1(2),wrk1(3),...,wrk1(1+(nx-kx-1)*(ny-ky-1)) will
-c contain the values d(i)/max(d(i)),i=1,...,(nx-kx-1)*(ny-ky-1)
-c with d(i) the i-th diagonal element of the reduced triangular
-c matrix for calculating the b-spline coefficients. it includes
-c those elements whose square is less than eps,which are treat-
-c ed as 0 in the case of presumed rank deficiency (ier<-2).
-c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of
-c the array wrk1 as declared in the calling (sub)program.
-c lwrk1 must not be too small. let
-c u = nxest-kx-1, v = nyest-ky-1, km = max(kx,ky)+1,
-c ne = max(nxest,nyest), bx = kx*v+ky+1, by = ky*u+kx+1,
-c if(bx.le.by) b1 = bx, b2 = b1+v-ky
-c if(bx.gt.by) b1 = by, b2 = b1+u-kx then
-c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1
-c wrk2 : real array of dimension (lwrk2). used as workspace, but
-c only in the case a rank deficient system is encountered.
-c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of
-c the array wrk2 as declared in the calling (sub)program.
-c lwrk2 > 0 . a save upper boundfor lwrk2 = u*v*(b2+1)+b2
-c where u,v and b2 are as above. if there are enough data
-c points, scattered uniformly over the approximation domain
-c and if the smoothing factor s is not too small, there is a
-c good chance that this extra workspace is not needed. a lot
-c of memory might therefore be saved by setting lwrk2=1.
-c (see also ier > 10)
-c iwrk : integer array of dimension (kwrk). used as workspace.
-c kwrk : integer. on entry kwrk must specify the actual dimension of
-c the array iwrk as declared in the calling (sub)program.
-c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1).
-c ier : integer. unless the routine detects an error, ier contains a
-c non-positive value on exit, i.e.
-c ier=0 : normal return. the spline returned has a residual sum of
-c squares fp such that abs(fp-s)/s <= tol with tol a relat-
-c ive tolerance set to 0.001 by the program.
-c ier=-1 : normal return. the spline returned is an interpolating
-c spline (fp=0).
-c ier=-2 : normal return. the spline returned is the weighted least-
-c squares polynomial of degrees kx and ky. in this extreme
-c case fp gives the upper bound for the smoothing factor s.
-c ier<-2 : warning. the coefficients of the spline returned have been
-c computed as the minimal norm least-squares solution of a
-c (numerically) rank deficient system. (-ier) gives the rank.
-c especially if the rank deficiency which can be computed as
-c (nx-kx-1)*(ny-ky-1)+ier, is large the results may be inac-
-c curate. they could also seriously depend on the value of
-c eps.
-c ier=1 : error. the required storage space exceeds the available
-c storage space, as specified by the parameters nxest and
-c nyest.
-c probably causes : nxest or nyest too small. if these param-
-c eters are already large, it may also indicate that s is
-c too small
-c the approximation returned is the weighted least-squares
-c spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=2 : error. a theoretically impossible result was found during
-c the iteration proces for finding a smoothing spline with
-c fp = s. probably causes : s too small or badly chosen eps.
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=3 : error. the maximal number of iterations maxit (set to 20
-c by the program) allowed for finding a smoothing spline
-c with fp=s has been reached. probably causes : s too small
-c there is an approximation returned but the corresponding
-c weighted sum of squared residuals does not satisfy the
-c condition abs(fp-s)/s < tol.
-c ier=4 : error. no more knots can be added because the number of
-c b-spline coefficients (nx-kx-1)*(ny-ky-1) already exceeds
-c the number of data points m.
-c probably causes : either s or m too small.
-c the approximation returned is the weighted least-squares
-c spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=5 : error. no more knots can be added because the additional
-c knot would (quasi) coincide with an old one.
-c probably causes : s too small or too large a weight to an
-c inaccurate data point.
-c the approximation returned is the weighted least-squares
-c spline according to the current set of knots.
-c the parameter fp gives the corresponding weighted sum of
-c squared residuals (fp>s).
-c ier=10 : error. on entry, the input data are controlled on validity
-c the following restrictions must be satisfied.
-c -1<=iopt<=1, 1<=kx,ky<=5, m>=(kx+1)*(ky+1), nxest>=2*kx+2,
-c nyest>=2*ky+2, 0<eps<1, nmax>=nxest, nmax>=nyest,
-c xb<=x(i)<=xe, yb<=y(i)<=ye, w(i)>0, i=1,...,m
-c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1
-c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1)
-c if iopt=-1: 2*kx+2<=nx<=nxest
-c xb<tx(kx+2)<tx(kx+3)<...<tx(nx-kx-1)<xe
-c 2*ky+2<=ny<=nyest
-c yb<ty(ky+2)<ty(ky+3)<...<ty(ny-ky-1)<ye
-c if iopt>=0: s>=0
-c if one of these conditions is found to be violated,control
-c is immediately repassed to the calling program. in that
-c case there is no approximation returned.
-c ier>10 : error. lwrk2 is too small, i.e. there is not enough work-
-c space for computing the minimal least-squares solution of
-c a rank deficient system of linear equations. ier gives the
-c requested value for lwrk2. there is no approximation re-
-c turned but, having saved the information contained in nx,
-c ny,tx,ty,wrk1, and having adjusted the value of lwrk2 and
-c the dimension of the array wrk2 accordingly, the user can
-c continue at the point the program was left, by calling
-c surfit with iopt=1.
-c
-c further comments:
-c by means of the parameter s, the user can control the tradeoff
-c between closeness of fit and smoothness of fit of the approximation.
-c if s is too large, the spline will be too smooth and signal will be
-c lost ; if s is too small the spline will pick up too much noise. in
-c the extreme cases the program will return an interpolating spline if
-c s=0 and the weighted least-squares polynomial (degrees kx,ky)if s is
-c very large. between these extremes, a properly chosen s will result
-c in a good compromise between closeness of fit and smoothness of fit.
-c to decide whether an approximation, corresponding to a certain s is
-c satisfactory the user is highly recommended to inspect the fits
-c graphically.
-c recommended values for s depend on the weights w(i). if these are
-c taken as 1/d(i) with d(i) an estimate of the standard deviation of
-c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+
-c sqrt(2*m)). if nothing is known about the statistical error in z(i)
-c each w(i) can be set equal to one and s determined by trial and
-c error, taking account of the comments above. the best is then to
-c start with a very large value of s ( to determine the least-squares
-c polynomial and the corresponding upper bound fp0 for s) and then to
-c progressively decrease the value of s ( say by a factor 10 in the
-c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
-c approximation shows more detail) to obtain closer fits.
-c to choose s very small is strongly discouraged. this considerably
-c increases computation time and memory requirements. it may also
-c cause rank-deficiency (ier<-2) and endager numerical stability.
-c to economize the search for a good s-value the program provides with
-c different modes of computation. at the first call of the routine, or
-c whenever he wants to restart with the initial set of knots the user
-c must set iopt=0.
-c if iopt=1 the program will continue with the set of knots found at
-c the last call of the routine. this will save a lot of computation
-c time if surfit is called repeatedly for different values of s.
-c the number of knots of the spline returned and their location will
-c depend on the value of s and on the complexity of the shape of the
-c function underlying the data. if the computation mode iopt=1
-c is used, the knots returned may also depend on the s-values at
-c previous calls (if these were smaller). therefore, if after a number
-c of trials with different s-values and iopt=1, the user can finally
-c accept a fit as satisfactory, it may be worthwhile for him to call
-c surfit once more with the selected value for s but now with iopt=0.
-c indeed, surfit may then return an approximation of the same quality
-c of fit but with fewer knots and therefore better if data reduction
-c is also an important objective for the user.
-c the number of knots may also depend on the upper bounds nxest and
-c nyest. indeed, if at a certain stage in surfit the number of knots
-c in one direction (say nx) has reached the value of its upper bound
-c (nxest), then from that moment on all subsequent knots are added
-c in the other (y) direction. this may indicate that the value of
-c nxest is too small. on the other hand, it gives the user the option
-c of limiting the number of knots the routine locates in any direction
-c for example, by setting nxest=2*kx+2 (the lowest allowable value for
-c nxest), the user can indicate that he wants an approximation which
-c is a simple polynomial of degree kx in the variable x.
-c
-c other subroutines required:
-c fpback,fpbspl,fpsurf,fpdisc,fpgivs,fprank,fprati,fprota,fporde
-c
-c references:
-c dierckx p. : an algorithm for surface fitting with spline functions
-c ima j. numer. anal. 1 (1981) 267-283.
-c dierckx p. : an algorithm for surface fitting with spline functions
-c report tw50, dept. computer science,k.u.leuven, 1980.
-c dierckx p. : curve and surface fitting with splines, monographs on
-c numerical analysis, oxford university press, 1993.
-c
-c author:
-c p.dierckx
-c dept. computer science, k.u. leuven
-c celestijnenlaan 200a, b-3001 heverlee, belgium.
-c e-mail : Paul.Dierckx at cs.kuleuven.ac.be
-c
-c creation date : may 1979
-c latest update : march 1987
-c
-c ..
-c ..scalar arguments..
- real*8 xb,xe,yb,ye,s,eps,fp
- integer iopt,m,kx,ky,nxest,nyest,nmax,nx,ny,lwrk1,lwrk2,kwrk,ier
-c ..array arguments..
- real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax),
- * c((nxest-kx-1)*(nyest-ky-1)),wrk1(lwrk1),wrk2(lwrk2)
- integer iwrk(kwrk)
-c ..local scalars..
- real*8 tol
- integer i,ib1,ib3,jb1,ki,kmax,km1,km2,kn,kwest,kx1,ky1,la,lbx,
- * lby,lco,lf,lff,lfp,lh,lq,lsx,lsy,lwest,maxit,ncest,nest,nek,
- * nminx,nminy,nmx,nmy,nreg,nrint,nxk,nyk
-c ..function references..
- integer max0
-c ..subroutine references..
-c fpsurf
-c ..
-c we set up the parameters tol and maxit.
- maxit = 20
- tol = 0.1e-02
-c before starting computations a data check is made. if the input data
-c are invalid,control is immediately repassed to the calling program.
- ier = 10
- if(eps.le.0. .or. eps.ge.1.) go to 71
- if(kx.le.0 .or. kx.gt.5) go to 71
- kx1 = kx+1
- if(ky.le.0 .or. ky.gt.5) go to 71
- ky1 = ky+1
- kmax = max0(kx,ky)
- km1 = kmax+1
- km2 = km1+1
- if(iopt.lt.(-1) .or. iopt.gt.1) go to 71
- if(m.lt.(kx1*ky1)) go to 71
- nminx = 2*kx1
- if(nxest.lt.nminx .or. nxest.gt.nmax) go to 71
- nminy = 2*ky1
- if(nyest.lt.nminy .or. nyest.gt.nmax) go to 71
- nest = max0(nxest,nyest)
- nxk = nxest-kx1
- nyk = nyest-ky1
- ncest = nxk*nyk
- nmx = nxest-nminx+1
- nmy = nyest-nminy+1
- nrint = nmx+nmy
- nreg = nmx*nmy
- ib1 = kx*nyk+ky1
- jb1 = ky*nxk+kx1
- ib3 = kx1*nyk+1
- if(ib1.le.jb1) go to 10
- ib1 = jb1
- ib3 = ky1*nxk+1
- 10 lwest = ncest*(2+ib1+ib3)+2*(nrint+nest*km2+m*km1)+ib3
- kwest = m+nreg
- if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 71
- if(xb.ge.xe .or. yb.ge.ye) go to 71
- do 20 i=1,m
- if(w(i).le.0.) go to 70
- if(x(i).lt.xb .or. x(i).gt.xe) go to 71
- if(y(i).lt.yb .or. y(i).gt.ye) go to 71
- 20 continue
- if(iopt.ge.0) go to 50
- if(nx.lt.nminx .or. nx.gt.nxest) go to 71
- nxk = nx-kx1
- tx(kx1) = xb
- tx(nxk+1) = xe
- do 30 i=kx1,nxk
- if(tx(i+1).le.tx(i)) go to 72
- 30 continue
- if(ny.lt.nminy .or. ny.gt.nyest) go to 71
- nyk = ny-ky1
- ty(ky1) = yb
- ty(nyk+1) = ye
- do 40 i=ky1,nyk
- if(ty(i+1).le.ty(i)) go to 73
- 40 continue
- go to 60
- 50 if(s.lt.0.) go to 71
- 60 ier = 0
-c we partition the working space and determine the spline approximation
- kn = 1
- ki = kn+m
- lq = 2
- la = lq+ncest*ib3
- lf = la+ncest*ib1
- lff = lf+ncest
- lfp = lff+ncest
- lco = lfp+nrint
- lh = lco+nrint
- lbx = lh+ib3
- nek = nest*km2
- lby = lbx+nek
- lsx = lby+nek
- lsy = lsx+m*km1
- call fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
- * eps,tol,maxit,nest,km1,km2,ib1,ib3,ncest,nrint,nreg,nx,tx,
- * ny,ty,c,fp,wrk1(1),wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff),
- * wrk1(la),wrk1(lq),wrk1(lbx),wrk1(lby),wrk1(lsx),wrk1(lsy),
- * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier)
- 70 return
- 71 print*,"iopt,kx,ky,m=",iopt,kx,ky,m
- print*,"nxest,nyest,nmax=",nxest,nyest,nmax
- print*,"lwrk1,lwrk2,kwrk=",lwrk1,lwrk2,kwrk
- print*,"xb,xe,yb,ye=",xb,xe,yb,ye
- print*,"eps,s",eps,s
- return
- 72 print*,"tx=",tx
- return
- 73 print*,"ty=",ty
- return
- end
Copied: branches/Interpolate1D/extensions/interpolate.h (from rev 4587, branches/Interpolate1D/interpolate.h)
Copied: branches/Interpolate1D/extensions/multipack.h (from rev 4587, branches/Interpolate1D/multipack.h)
Copied: branches/Interpolate1D/extensions/ndimage (from rev 4601, branches/Interpolate1D/ndimage)
Deleted: branches/Interpolate1D/interpolate.h
===================================================================
--- branches/Interpolate1D/interpolate.h 2008-08-07 21:05:37 UTC (rev 4609)
+++ branches/Interpolate1D/interpolate.h 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,206 +0,0 @@
-#include <time.h>
-#include <math.h>
-#include <iostream>
-#include <algorithm>
-
-template <class T>
-void linear(T* x_vec, T* y_vec, int len,
- T* new_x_vec, T* new_y_vec, int new_len)
-{
- for (int i=0;i<new_len;i++)
- {
- T new_x = new_x_vec[i];
- int index;
- if (new_x <= x_vec[0])
- index = 0;
- else if (new_x >=x_vec[len-1])
- index = len-2;
- else
- {
- T* which = std::lower_bound(x_vec, x_vec+len, new_x);
- index = which - x_vec-1;
- }
-
- if(new_x == x_vec[index])
- {
- // exact value
- new_y_vec[i] = y_vec[index];
- }
- else
- {
- //interpolate
- double x_lo = x_vec[index];
- double x_hi = x_vec[index+1];
- double y_lo = y_vec[index];
- double y_hi = y_vec[index+1];
- double slope = (y_hi-y_lo)/(x_hi-x_lo);
- new_y_vec[i] = slope * (new_x-x_lo) + y_lo;
- }
- }
-}
-
-template <class T>
-void loginterp(T* x_vec, T* y_vec, int len,
- T* new_x_vec, T* new_y_vec, int new_len)
-{
- for (int i=0;i<new_len;i++)
- {
- T new_x = new_x_vec[i];
- int index;
- if (new_x <= x_vec[0])
- index = 0;
- else if (new_x >=x_vec[len-1])
- index = len-2;
- else
- {
- T* which = std::lower_bound(x_vec, x_vec+len, new_x);
- index = which - x_vec-1;
- }
-
- if(new_x == x_vec[index])
- {
- // exact value
- new_y_vec[i] = y_vec[index];
- }
- else
- {
- //interpolate
- double x_lo = x_vec[index];
- double x_hi = x_vec[index+1];
- double y_lo = log10(y_vec[index]);
- double y_hi = log10(y_vec[index+1]);
- double slope = (y_hi-y_lo)/(x_hi-x_lo);
- new_y_vec[i] = pow(10.0, (slope * (new_x-x_lo) + y_lo));
- }
- }
-}
-
-template <class T>
-int block_average_above(T* x_vec, T* y_vec, int len,
- T* new_x_vec, T* new_y_vec, int new_len)
-{
- int bad_index = -1;
- int start_index = 0;
- T last_y = 0.0;
- T thickness = 0.0;
-
- for(int i=0;i<new_len;i++)
- {
- T new_x = new_x_vec[i];
- if ((new_x < x_vec[0]) || (new_x > x_vec[len-1]))
- {
- bad_index = i;
- break;
- }
- else if (new_x == x_vec[0])
- {
- // for the first sample, just return the cooresponding y value
- new_y_vec[i] = y_vec[0];
- }
- else
- {
- T* which = std::lower_bound(x_vec, x_vec+len, new_x);
- int index = which - x_vec-1;
-
- // calculate weighted average
-
- // Start off with "residue" from last interval in case last x
- // was between to samples.
- T weighted_y_sum = last_y * thickness;
- T thickness_sum = thickness;
- for(int j=start_index; j<=index; j++)
- {
- T next_x;
- if (x_vec[j+1] < new_x)
- thickness = x_vec[j+1] - x_vec[j];
- else
- thickness = new_x -x_vec[j];
- weighted_y_sum += y_vec[j] * thickness;
- thickness_sum += thickness;
- }
- new_y_vec[i] = weighted_y_sum/thickness_sum;
-
- // Store the thickness between the x value and the next sample
- // to add to the next weighted average.
- last_y = y_vec[index];
- thickness = x_vec[index+1] - new_x;
-
- // start next weighted average at next sample
- start_index =index+1;
- }
- }
- return bad_index;
-}
-
-template <class T>
-int window_average(T* x_vec, T* y_vec, int len,
- T* new_x_vec, T* new_y_vec, int new_len,
- T width)
-{
- for(int i=0;i<new_len;i++)
- {
- T new_x = new_x_vec[i];
- T bottom = new_x - width/2;
- T top = new_x + width/2;
-
- T* which = std::lower_bound(x_vec, x_vec+len, bottom);
- int bottom_index = which - x_vec;
- if (bottom_index < 0)
- {
- //bottom = x_vec[0];
- bottom_index = 0;
- }
-
- which = std::lower_bound(x_vec, x_vec+len, top);
- int top_index = which - x_vec;
- if (top_index >= len)
- {
- //top = x_vec[len-1];
- top_index = len-1;
- }
- //std::cout << std::endl;
- //std::cout << bottom_index << " " << top_index << std::endl;
- //std::cout << bottom << " " << top << std::endl;
- // calculate weighted average
- T thickness =0.0;
- T thickness_sum =0.0;
- T weighted_y_sum =0.0;
- for(int j=bottom_index; j < top_index; j++)
- {
- thickness = x_vec[j+1] - bottom;
- weighted_y_sum += y_vec[j] * thickness;
- thickness_sum += thickness;
- bottom = x_vec[j+1];
- /*
- std::cout << "iter: " << j - bottom_index << " " <<
- "index: " << j << " " <<
- "bottom: " << bottom << " " <<
- "x+1: " << x_vec[j+1] << " " <<
- "x: " << x_vec[j] << " " <<
- "y: " << y_vec[j] << " " <<
- "weighted_sum: " << weighted_y_sum <<
- "thickness: " << thickness << " " <<
- "thickness_sum: " << thickness_sum << std::endl;
- */
- //std::cout << x_vec[j] << " ";
- //std::cout << thickness << " ";
- }
-
- // last element
- thickness = top - bottom;
- weighted_y_sum += y_vec[top_index] * thickness;
- thickness_sum += thickness;
- /*
- std::cout << "iter: last" << " " <<
- "index: " << top_index << " " <<
- "x: " << x_vec[top_index] << " " <<
- "y: " << y_vec[top_index] << " " <<
- "weighted_sum: " << weighted_y_sum <<
- "thickness: " << thickness << " " <<
- "thickness_sum: " << thickness_sum << std::endl;
- */
- //std::cout << x_vec[top_index] << " " << thickness_sum << std::endl;
- new_y_vec[i] = weighted_y_sum/thickness_sum;
- }
- return -1;
-}
Deleted: branches/Interpolate1D/multipack.h
===================================================================
--- branches/Interpolate1D/multipack.h 2008-08-07 21:05:37 UTC (rev 4609)
+++ branches/Interpolate1D/multipack.h 2008-08-07 21:25:16 UTC (rev 4610)
@@ -1,211 +0,0 @@
-/* MULTIPACK module by Travis Oliphant
-
-Copyright (c) 2002 Travis Oliphant all rights reserved
-Oliphant.Travis at altavista.net
-Permission to use, modify, and distribute this software is given under the
-terms of the SciPy (BSD style) license. See LICENSE.txt that came with
-this distribution for specifics.
-
-NO WARRANTY IS EXPRESSED OR IMPLIED. USE AT YOUR OWN RISK.
-*/
-
-
-/* This extension module is a collection of wrapper functions around
-common FORTRAN code in the packages MINPACK, ODEPACK, and QUADPACK plus
-some differential algebraic equation solvers.
-
-The wrappers are meant to be nearly direct translations between the
-FORTAN code and Python. Some parameters like sizes do not need to be
-passed since they are available from the objects.
-
-It is anticipated that a pure Python module be written to call these lower
-level routines and make a simpler user interface. All of the routines define
-default values for little-used parameters so that even the raw routines are
-quite useful without a separate wrapper.
-
-FORTRAN Outputs that are not either an error indicator or the sought-after
-results are placed in a dictionary and returned as an optional member of
-the result tuple when the full_output argument is non-zero.
-*/
-
-#include "Python.h"
-#include "numpy/arrayobject.h"
-
-#define PYERR(errobj,message) {PyErr_SetString(errobj,message); goto fail;}
-#define PYERR2(errobj,message) {PyErr_Print(); PyErr_SetString(errobj, message); goto fail;}
-#define ISCONTIGUOUS(m) ((m)->flags & CONTIGUOUS)
-
-#define STORE_VARS() PyObject *store_multipack_globals[4]; int store_multipack_globals3;
-
-#define INIT_FUNC(fun,arg,errobj) { /* Get extra arguments or set to zero length tuple */ \
- store_multipack_globals[0] = multipack_python_function; \
- store_multipack_globals[1] = multipack_extra_arguments; \
- if (arg == NULL) { \
- if ((arg = PyTuple_New(0)) == NULL) goto fail; \
- } \
- else \
- Py_INCREF(arg); /* We decrement on exit. */ \
- if (!PyTuple_Check(arg)) \
- PYERR(errobj,"Extra Arguments must be in a tuple"); \
- /* Set up callback functions */ \
- if (!PyCallable_Check(fun)) \
- PYERR(errobj,"First argument must be a callable function."); \
- multipack_python_function = fun; \
- multipack_extra_arguments = arg; }
-
-#define INIT_JAC_FUNC(fun,Dfun,arg,col_deriv,errobj) { \
- store_multipack_globals[0] = multipack_python_function; \
- store_multipack_globals[1] = multipack_extra_arguments; \
- store_multipack_globals[2] = multipack_python_jacobian; \
- store_multipack_globals3 = multipack_jac_transpose; \
- if (arg == NULL) { \
- if ((arg = PyTuple_New(0)) == NULL) goto fail; \
- } \
- else \
- Py_INCREF(arg); /* We decrement on exit. */ \
- if (!PyTuple_Check(arg)) \
- PYERR(errobj,"Extra Arguments must be in a tuple"); \
- /* Set up callback functions */ \
- if (!PyCallable_Check(fun) || (Dfun != Py_None && !PyCallable_Check(Dfun))) \
- PYERR(errobj,"The function and its Jacobian must be callable functions."); \
- multipack_python_function = fun; \
- multipack_extra_arguments = arg; \
- multipack_python_jacobian = Dfun; \
- multipack_jac_transpose = !(col_deriv);}
-
-#define RESTORE_JAC_FUNC() multipack_python_function = store_multipack_globals[0]; \
- multipack_extra_arguments = store_multipack_globals[1]; \
- multipack_python_jacobian = store_multipack_globals[2]; \
- multipack_jac_transpose = store_multipack_globals3;
-
-#define RESTORE_FUNC() multipack_python_function = store_multipack_globals[0]; \
- multipack_extra_arguments = store_multipack_globals[1];
-
-#define SET_DIAG(ap_diag,o_diag,mode) { /* Set the diag vector from input */ \
- if (o_diag == NULL || o_diag == Py_None) { \
- ap_diag = (PyArrayObject *)PyArray_FromDims(1,&n,PyArray_DOUBLE); \
- if (ap_diag == NULL) goto fail; \
- diag = (double *)ap_diag -> data; \
- mode = 1; \
- } \
- else { \
- ap_diag = (PyArrayObject *)PyArray_ContiguousFromObject(o_diag, PyArray_DOUBLE, 1, 1); \
- if (ap_diag == NULL) goto fail; \
- diag = (double *)ap_diag -> data; \
- mode = 2; } }
-
-#define MATRIXC2F(jac,data,n,m) {double *p1=(double *)(jac), *p2, *p3=(double *)(data);\
-int i,j;\
-for (j=0;j<(m);p3++,j++) \
- for (p2=p3,i=0;i<(n);p2+=(m),i++,p1++) \
- *p1 = *p2; }
-/*
-static PyObject *multipack_python_function=NULL;
-static PyObject *multipack_python_jacobian=NULL;
-static PyObject *multipack_extra_arguments=NULL;
-static int multipack_jac_transpose=1;
-*/
-
-static PyArrayObject * my_make_numpy_array(PyObject *y0, int type, int mindim, int maxdim)
- /* This is just like PyArray_ContiguousFromObject except it handles
- * single numeric datatypes as 1-element, rank-1 arrays instead of as
- * scalars.
- */
-{
- PyArrayObject *new_array;
- PyObject *tmpobj;
-
- Py_INCREF(y0);
-
- if (PyInt_Check(y0) || PyFloat_Check(y0)) {
- tmpobj = PyList_New(1);
- PyList_SET_ITEM(tmpobj, 0, y0); /* reference now belongs to tmpobj */
- }
- else
- tmpobj = y0;
-
- new_array = (PyArrayObject *)PyArray_ContiguousFromObject(tmpobj, type, mindim, maxdim);
-
- Py_DECREF(tmpobj);
- return new_array;
-}
-
-static PyObject *call_python_function(PyObject *func, int n, double *x, PyObject *args, int dim, PyObject *error_obj)
-{
- /*
- This is a generic function to call a python function that takes a 1-D
- sequence as a first argument and optional extra_arguments (should be a
- zero-length tuple if none desired). The result of the function is
- returned in a multiarray object.
- -- build sequence object from values in x.
- -- add extra arguments (if any) to an argument list.
- -- call Python callable object
- -- check if error occurred:
- if so return NULL
- -- if no error, place result of Python code into multiarray object.
- */
-
- PyArrayObject *sequence = NULL;
- PyObject *arglist = NULL, *tmpobj = NULL;
- PyObject *arg1 = NULL, *str1 = NULL;
- PyObject *result = NULL;
- PyArrayObject *result_array = NULL;
-
- /* Build sequence argument from inputs */
- sequence = (PyArrayObject *)PyArray_FromDimsAndData(1, &n, PyArray_DOUBLE, (char *)x);
- if (sequence == NULL) PYERR2(error_obj,"Internal failure to make an array of doubles out of first\n argument to function call.");
-
- /* Build argument list */
- if ((arg1 = PyTuple_New(1)) == NULL) {
- Py_DECREF(sequence);
- return NULL;
- }
- PyTuple_SET_ITEM(arg1, 0, (PyObject *)sequence);
- /* arg1 now owns sequence reference */
- if ((arglist = PySequence_Concat( arg1, args)) == NULL)
- PYERR2(error_obj,"Internal error constructing argument list.");
-
- Py_DECREF(arg1); /* arglist has a reference to sequence, now. */
-
-
- /* Call function object --- variable passed to routine. Extra
- arguments are in another passed variable.
- */
- if ((result = PyEval_CallObject(func, arglist))==NULL) {
- PyErr_Print();
- tmpobj = PyObject_GetAttrString(func, "func_name");
- if (tmpobj == NULL) goto fail;
- str1 = PyString_FromString("Error occured while calling the Python function named ");
- if (str1 == NULL) { Py_DECREF(tmpobj); goto fail;}
- PyString_ConcatAndDel(&str1, tmpobj);
- PyErr_SetString(error_obj, PyString_AsString(str1));
- Py_DECREF(str1);
- goto fail;
- }
-
- if ((result_array = (PyArrayObject *)PyArray_ContiguousFromObject(result, PyArray_DOUBLE, dim-1, dim))==NULL)
- PYERR2(error_obj,"Result from function call is not a proper array of floats.");
-
- Py_DECREF(result);
- Py_DECREF(arglist);
- return (PyObject *)result_array;
-
- fail:
- Py_XDECREF(arglist);
- Py_XDECREF(result);
- Py_XDECREF(arg1);
- return NULL;
-}
-
-
-
-
-
-
-
-
-
-
-
-
-
Modified: branches/Interpolate1D/setup.py
===================================================================
--- branches/Interpolate1D/setup.py 2008-08-07 21:05:37 UTC (rev 4609)
+++ branches/Interpolate1D/setup.py 2008-08-07 21:25:16 UTC (rev 4610)
@@ -13,31 +13,31 @@
# C++ extension for several basic interpolation types
config.add_extension('_interpolate',
- ['_interpolate.cpp'],
- include_dirs = ['.'],
- depends = ['interpolate.h'])
+ ['extensions/_interpolate.cpp'],
+ include_dirs = ['extensions'],
+ depends = ['extensions/interpolate.h'])
# used by dfitpack extension
config.add_library('_fitpack',
- sources=[join('fitpack', '*.f')],
+ sources=[join('extensions/fitpack', '*.f')],
)
# Fortran routines (collectively "FITPACK" for spline interpolation)
config.add_extension('_dfitpack',
- sources=['_fitpack.pyf'],
+ sources=['extensions/_fitpack.pyf'],
libraries=['_fitpack'],
)
# ND Image routines for ND interpolation
config.add_extension('_nd_image',
- sources=["ndimage/nd_image.c",
- "ndimage/ni_filters.c",
- "ndimage/ni_fourier.c",
- "ndimage/ni_interpolation.c",
- "ndimage/ni_measure.c",
- "ndimage/ni_morphology.c",
- "ndimage/ni_support.c"],
- include_dirs=['ndimage']+[get_include()],
+ sources=["extensions/ndimage/nd_image.c",
+ "extensions/ndimage/ni_filters.c",
+ "extensions/ndimage/ni_fourier.c",
+ "extensions/ndimage/ni_interpolation.c",
+ "extensions/ndimage/ni_measure.c",
+ "extensions/ndimage/ni_morphology.c",
+ "extensions/ndimage/ni_support.c"],
+ include_dirs=['extensions/ndimage']+[get_include()],
)
config.add_data_dir('docs')
More information about the Scipy-svn
mailing list