V3FIT
bpspline.f
1 c bpspline -- dmc 30 May 1996
2 c
3 c set up coefficients for bicubic spline with following BC's:
4 c * LHS and RHS BCs -- d3f/dx3 from 3rd divided difference, 1st coordinate
5 c * derivatives periodic in second coordinate
6 c
7 c see similar routine, bpsplinb, for more control over x boundary
8 c conditions...
9 c
10  subroutine bpspline(x,inx,th,inth,fspl,inf3,
11  > wk,nwk,ilinx,ilinth,ier)
12 c
13  implicit NONE
14  integer inx,inth,inf3,nwk
15  real x(inx),th(inth),fspl(4,4,inf3,inth),wk(nwk)
16  integer ilinx,ilinth
17  integer ier
18 c
19 c input:
20 c x(1...inx) -- abscissae, first dimension of data
21 c th(1...inth) -- abscissae, second (periodic) dimension of data
22 c fspl(1,1,1..inx,1..inth) -- function values
23 c inf3 -- fspl dimensioning, inf3.ge.inx required.
24 c
25 c output:
26 c fspl(*,*,1..inx,1..inth) -- bicubic spline coeffs (4x4)
27 c ...fspl(1,1,*,*) is not replaced.
28 c
29 c ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
30 c ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
31 c
32 c ier -- completion code, 0 for normal
33 c
34 c workspace:
35 c wk -- must be at least 5*max(inx,inth) large
36 c nwk -- size of workspace
37 c
38 c---------------------------------
39 c compute bicubic spline of 2d function, given values at the grid
40 c grid crossing points, f(1,1,i,j)=f(x(i),th(j)).
41 c
42 c on evaluation: for point x btw x(i) and x(i+1), dx=x-x(i)
43 c and th btw th(j) and th(j+1), dt=th-th(j),
44 c
45 c spline =
46 c f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
47 c +dt*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
48 c +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
49 c +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
50 c
51 c where d2=dt**2 and d3=dt**3.
52 c
53 c---------------------------------
54  integer ierx,ierth
55  real zdum(1)
56 c---------------------------------
57 c
58  ier=0
59  if(nwk.lt.5*max(inx,inth)) then
60  write(6,'('' ?bpspline: workspace too small.'')')
61  ier=1
62  endif
63  if(inx.lt.2) then
64  write(6,'('' ?bpspline: at least 2 x points required.'')')
65  ier=1
66  endif
67  if(inth.lt.2) then
68  write(6,'('' ?bpspline: need at least 2 theta points.'')')
69  ier=1
70  endif
71 c
72 c check ilinx & x vector
73 c
74  call splinck(x,inx,ilinx,1.0e-3,ierx)
75  if(ierx.ne.0) ier=2
76 c
77  if(ier.eq.2) then
78  write(6,'('' ?bpspline: x axis not strict ascending'')')
79  endif
80 c
81 c check ilinth & th vector
82 c
83  call splinck(th,inth,ilinth,1.0e-3,ierth)
84  if(ierth.ne.0) ier=3
85 c
86  if(ier.eq.3) then
87  write(6,'('' ?bpspline: th axis not strict ascending'')')
88  endif
89 c
90  if(ier.ne.0) return
91 c
92 c------------------------------------
93 c
94  zdum=0.0
95 c
96 c not-a-knot BCs for x, periodic for theta
97 c
98  call bcspline(x,inx,th,inth,fspl,inf3,
99  > 7,zdum,7,zdum,
100  > -1,zdum,-1,zdum,
101  > wk,nwk,ilinx,ilinth,ier)
102 c
103  return
104  end