[Fortran] 纯文本查看 复制代码
program Test_SurfaceFitting
INCLUDE 'link_fnl_shared.h'
use numerical_libraries
USE surface_fitting_int
USE rand_int
USE norm_int
implicit none
! This is Example 1 for SURFACE_FITTING, tensor product
! B-splines approximation. Use the function
! exp(-x**2-y**2) on the square (0, 2) x (0, 2) for samples.
! The spline order is "nord" and the number of cells is
! "(ngrid-1)**2". There are "ndata" data values in the square.
integer :: i
integer, parameter :: ngrid=9, nord=4, ndegree=nord-1, &
nbkpt=ngrid+2*ndegree, ndata = 2000, nvalues=100
real(kind(1d0)), parameter :: zero=0d0, one=1d0, two=2d0
real(kind(1d0)), parameter :: TOLERANCE=1d-3
real(kind(1d0)), target :: spline_data (4, ndata), bkpt(nbkpt), &
& coeff(ngrid+ndegree-1,ngrid+ndegree-1), delta, sizev, &
& x(nvalues), y(nvalues), values(nvalues, nvalues)
real(kind(1d0)), pointer :: pointer_bkpt(:)
type (d_spline_knots) knotsx, knotsy
! Set Random Number generator seed
real(kind(1d0)),parameter::zero_par=0.d0
real(kind(1d0))::dummy_par(0)
integer iseed_par,lev_par
type(d_options)::iopti_par(2)
iseed_par = 53976279
iopti_par(1)=d_options(d_rand_gen_generator_seed,zero_par)
iopti_par(2)=d_options(iseed_par,zero_par)
call rand_gen(dummy_par,iopt=iopti_par)
! Generate random (x,y) pairs and evaluate the
! example exponential function at these values.
spline_data(1:2,:)=two*rand(spline_data(1:2,:))
spline_data(3,:)=exp(-sum(spline_data(1:2,:)**2,dim=1))
spline_data(4,:)=one
! Define the knots for the tensor product data fitting problem.
delta = two/(ngrid-1)
bkpt(1:ndegree) = zero
bkpt(nbkpt-ndegree+1:nbkpt) = two
bkpt(nord:nbkpt-ndegree)=(/(i*delta,i=0,ngrid-1)/)
! Assign the degree of the polynomial and the knots.
knotsx%spline_degree=ndegree
knotsx%d_knots=>bkpt
knotsy%spline_degree=knotsx%spline_degree
knotsy%d_knots=>knotsx%d_knots
! Fit the data and obtain the coefficients.
coeff = surface_fitting(spline_data, knotsx, knotsy)
! Evaluate the residual = spline - function
! at a grid of points inside the square.
delta=two/(nvalues+1)
x=(/(i*delta,i=1,nvalues)/); y=x
values=exp(-spread(x**2,1,nvalues)-spread(y**2,2,nvalues))
values=surface_values((/0,0/), x, y, knotsx, knotsy, coeff)-values
! Compute the R.M.S. error:
sizev=norm(pack(values, (values == values)))/nvalues
if (sizev <= TOLERANCE) then
write (*,*) 'SURFACE_FITTING_EX1 Passed on pcdsms.'
else
write(*,*) 'SURFACE_FITTING_EX1 ********** Failed on pcdsms **********'
end if
end program