! E02DCF Example Program Text
! Mark 30.0 Release. NAG Copyright 2024.
Module e02dcfe_mod
! E02DCF Example Program Module:
! Parameters and User-defined Routines
! .. Use Statements ..
Use nag_library, Only: nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Accessibility Statements ..
Private
Public :: cprint
! .. Parameters ..
Integer, Parameter, Public :: nin = 5, nout = 6
Contains
Subroutine cprint(c,ny,nx,nout)
! .. Scalar Arguments ..
Integer, Intent (In) :: nout, nx, ny
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (In) :: c(ny-4,nx-4)
! .. Local Scalars ..
Integer :: i
! .. Executable Statements ..
Write (nout,*)
Write (nout,*) 'The B-spline coefficients:'
Write (nout,*)
Do i = 1, ny - 4
Write (nout,99999) c(i,1:(nx-4))
End Do
Return
99999 Format (1X,8F9.4)
End Subroutine cprint
End Module e02dcfe_mod
Program e02dcfe
! E02DCF Example Main Program
! .. Use Statements ..
Use e02dcfe_mod, Only: cprint, nin, nout
Use nag_library, Only: e02dcf, e02dff, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Real (Kind=nag_wp) :: delta, fp, s, xhi, xlo, yhi, ylo
Integer :: i, ifail, j, liwrk, lwrk, mx, my, &
npx, npy, nx, nxest, ny, nyest
Character (1) :: start
! .. Local Arrays ..
Real (Kind=nag_wp), Allocatable :: c(:), f(:), fg(:), lamda(:), mu(:), &
px(:), py(:), wrk(:), x(:), y(:)
Integer, Allocatable :: iwrk(:)
! .. Intrinsic Procedures ..
Intrinsic :: max, min, real
! .. Executable Statements ..
Write (nout,*) 'E02DCF Example Program Results'
! Skip heading in data file
Read (nin,*)
! Input the number of X, Y co-ordinates MX, MY.
Read (nin,*) mx, my
nxest = mx + 4
nyest = my + 4
lwrk = 4*(mx+my) + 11*(nxest+nyest) + nxest*my + max(my,nxest) + 54
liwrk = 3 + mx + my + nxest + nyest
Allocate (x(mx),y(my),f(mx*my),lamda(nxest),mu(nyest),wrk(lwrk), &
iwrk(liwrk),c((nxest-4)*(nyest-4)))
Read (nin,*) x(1:mx)
Read (nin,*) y(1:my)
! Input the MX*MY function values F at the grid points.
Read (nin,*) f(1:mx*my)
start = 'C'
Read (nin,*) s
! Determine the spline approximation.
ifail = 0
Call e02dcf(start,mx,x,my,y,f,s,nxest,nyest,nx,lamda,ny,mu,c,fp,wrk, &
lwrk,iwrk,liwrk,ifail)
Deallocate (wrk,iwrk)
Write (nout,*)
Write (nout,99999) 'Calling with smoothing factor S =', s, ': NX =', nx, &
', NY =', ny, '.'
Write (nout,*)
Write (nout,*) ' I Knot LAMDA(I) J Knot MU(J)'
Write (nout,*)
Do j = 4, max(nx,ny) - 3
If (j<=nx-3 .And. j<=ny-3) Then
Write (nout,99997) j, lamda(j), j, mu(j)
Else If (j<=nx-3) Then
Write (nout,99997) j, lamda(j)
Else If (j<=ny-3) Then
Write (nout,99996) j, mu(j)
End If
End Do
Call cprint(c,ny,nx,nout)
Write (nout,*)
Write (nout,99998) 'Sum of squared residuals FP =', fp
If (fp==0.0E+0_nag_wp) Then
Write (nout,*) '(The spline is an interpolating spline)'
Else If (nx==8 .And. ny==8) Then
Write (nout,*) '(The spline is the least squares bi-cubic polynomial)'
End If
! Evaluate the spline on a rectangular grid at NPX*NPY points
! over the domain (XLO to XHI) x (YLO to YHI).
Read (nin,*) npx, xlo, xhi
Read (nin,*) npy, ylo, yhi
lwrk = min(4*npx+nx,4*npy+ny)
If (4*npx+nx>4*npy+ny) Then
liwrk = npy + ny - 4
Else
liwrk = npx + nx - 4
End If
Allocate (px(npx),py(npy),fg(npx*npy),wrk(lwrk),iwrk(liwrk))
delta = (xhi-xlo)/real(npx-1,kind=nag_wp)
Do i = 1, npx
px(i) = min(xlo+real(i-1,kind=nag_wp)*delta,xhi)
End Do
delta = (yhi-ylo)/real(npy-1,kind=nag_wp)
Do i = 1, npy
py(i) = min(ylo+real(i-1,kind=nag_wp)*delta,yhi)
End Do
ifail = 0
Call e02dff(npx,npy,nx,ny,px,py,lamda,mu,c,fg,wrk,lwrk,iwrk,liwrk,ifail)
Write (nout,*)
Write (nout,*) 'Values of computed spline:'
Write (nout,*)
Write (nout,99995) ' X', (px(i),i=1,npx)
Write (nout,*) ' Y'
Do i = npy, 1, -1
Write (nout,99994) py(i), (fg(npy*(j-1)+i),j=1,npx)
End Do
99999 Format (1X,A,1P,E13.4,A,I5,A,I5,A)
99998 Format (1X,A,1P,E13.4)
99997 Format (1X,I16,F12.4,I11,F12.4)
99996 Format (1X,I39,F12.4)
99995 Format (1X,A,7F8.2)
99994 Format (1X,F8.2,3X,7F8.2)
End Program e02dcfe