V3FIT
bcspline.f
1 c bcspline -- dmc 30 May 1996
2 c
3 c set up coefficients for bicubic spline with following BC's:
4 c FULL BC CONTROL at all bdys
5 c
6 c inhomogeneous explicit BCs -- this means setting of 1st or 2nd
7 c derivative at boundary to a non-zero value.
8 c
9 c periodic, not-a-knot, zero derivative, and divided-difference based
10 c BCs are "homogeneous"-- i.e. if splines s & t satisfy the BC then
11 c the spline (c*s + t) formed as a linear combination of these two
12 c splines, also satisfies the BC.
13 c
14 c algorithm note -- handling of inhomogeneous explicit BC's while
15 c maintaining full C2 differentiability is delicate. Basic method: use
16 c a fully C2 method based on the "not-a-knot" BC, and then, correct to
17 c meet each user BC by calculating a C2 spline that is zero at all grid
18 c points but satisfies a BC which is the difference btw the user spec
19 c and the not-a-knot result; add the coeffs of this into the original.
20 c
21 c for this more workspace is needed: nwk .ge. 4*inx*inth +5*max(inx,inth)
22 c
23  subroutine bcspline(x,inx,th,inth,fspl,inf3,
24  > ibcxmin,bcxmin,ibcxmax,bcxmax,
25  > ibcthmin,bcthmin,ibcthmax,bcthmax,
26  > wk,nwk,ilinx,ilinth,ier)
27 c
28  real x(inx),th(inth),fspl(4,4,inf3,inth),wk(nwk)
29  real bcxmin(*),bcxmax(*) ! (inth) if used
30  real bcthmin(*),bcthmax(*) ! (inx) if used
31 c
32 c input:
33 c x(1...inx) -- abscissae, first dimension of data
34 c th(1...inth) -- abscissae, second dimension of data f(x,th)
35 c fspl(1,1,1..inx,1..inth) -- function values
36 c inf3 -- fspl dimensioning, inf3.ge.inx required.
37 c
38 c boundary conditions input:
39 c ibcxmin -- indicator for boundary condition at x(1):
40 c bcxmin(...) -- boundary condition data
41 c =-1 -- periodic boundary condition
42 c =0 -- use "not a knot", bcxmin(...) ignored
43 c =1 -- match slope, specified at x(1),th(ith) by bcxmin(ith)
44 c =2 -- match 2nd derivative, specified at x(1),th(ith) by bcxmin(ith)
45 c =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all th(j)
46 c =4 -- boundary condition is d2f/dx2=0 at x(1), all th(j)
47 c =5 -- match 1st derivative df/dx to 1st divided difference
48 c =6 -- match 2nd derivative d2f/dx2 to 2nd divided difference
49 c =7 -- match 3rd derivative d3f/dx3 3rd divided difference
50 c (for more detailed definition of BCs 5-7, see the
51 c comments of subroutine mkspline)
52 c NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
53 c
54 c ibcxmax -- indicator for boundary condition at x(nx):
55 c bcxmax(...) -- boundary condition data
56 c (interpretation as with ibcxmin, bcxmin)
57 c NOTE: if ibcxmin=-1, ibcxmax is ignored! ...and the BC is periodic.
58 c
59 c ibcthmin -- indicator for boundary condition at th(1):
60 c bcthmin(...) -- boundary condition data
61 c (interpretation as with ibcxmin, bcxmin)
62 c ibcthmax -- indicator for boundary condition at th(inth):
63 c bcthmax(...) -- boundary condition data
64 c (interpretation as with ibcxmin, bcxmin)
65 c NOTE: if ibcthmin=-1, ibcthmax is ignored! ...and the BC is periodic.
66 c
67 c NOTE the bcxmin,bcxmax,bcthmin,bcthmax arrays are only used if the
68 c corresponding boundary condition flags are set to 1 or 2.
69 c Carefully note the dimensioning of these arrays!
70 c
71 c output:
72 c fspl(*,*,1..inx,1..inth) -- bicubic spline coeffs (4x4)
73 c ...fspl(1,1,*,*) is not replaced.
74 c
75 c ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
76 c ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
77 c
78 c ier -- completion code, 0 for normal
79 c
80 c workspace:
81 c wk -- must be at least 5*max(inx,inth) large
82 c 5*max(inx,inth) + 4*inx*inth large
83 c if explicit non-zero d/dth or d2/dth2 BC's
84 c are supplied.
85 c nwk -- size of workspace of workspace provided
86 c
87 c---------------------------------
88 c in what follows, "f" is an abbreviation for "fspl"...
89 c
90 c compute bicubic spline of 2d function, given values at the grid
91 c grid crossing points, f(1,1,i,j)=f(x(i),th(j)).
92 c
93 c on evaluation: for point x btw x(i) and x(i+1), dx=x-x(i)
94 c and th btw th(j) and th(j+1), dt=th-th(j),
95 c
96 c spline =
97 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)
98 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))
99 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))
100 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))
101 c
102 c where d2=dt**2 and d3=dt**3.
103 c
104  integer iselect1(10)
105  integer iselect2(10)
106 c
107  real zcur(1)
108 c---------------------------------
109 c
110 c see if 2nd pass is needed due to "non-linear" d/dth bdy cond.
111 c
112  iflg2=0
113  if(ibcthmin.ne.-1) then
114  if((ibcthmin.eq.1).or.(ibcthmin.eq.2)) then
115  do ix=1,inx
116  if (bcthmin(ix).ne.0.0) iflg2=1
117  enddo
118  endif
119  if((ibcthmax.eq.1).or.(ibcthmax.eq.2)) then
120  do ix=1,inx
121  if (bcthmax(ix).ne.0.0) iflg2=1
122  enddo
123  endif
124  endif
125 c
126  ier=0
127  itest=5*max(inx,inth)
128  if(iflg2.eq.1) then
129  itest=itest +4*inx*inth
130  endif
131 c
132  if(nwk.lt.itest) then
133  write(6,9901) nwk,itest
134  9901 format(' ?bcspline: workspace too small:'/
135  > ' user supplied: nwk=',i6,'; need at least: ',i6/
136  > ' nwk=4*nx*ny +5*max(nx,ny) will work for any user'/
137  > ' choice of bdy conditions.')
138  ier=1
139  endif
140  if(inx.lt.2) then
141  write(6,'('' ?bcspline: at least 2 x points required.'')')
142  ier=1
143  endif
144  if(inth.lt.2) then
145  write(6,'('' ?bcspline: need at least 2 theta points.'')')
146  ier=1
147  endif
148 c
149  call ibc_ck(ibcxmin,'bcspline','xmin',-1,7,ier)
150  if(ibcxmin.ge.0) call ibc_ck(ibcxmax,'bcspline','xmax',0,7,ier)
151  call ibc_ck(ibcthmin,'bcspline','thmin',-1,7,ier)
152  if(ibcthmin.ge.0) call ibc_ck(ibcthmax,'bcspline','thmax',0,7,ier)
153 c
154 c check ilinx & x vector
155 c
156  call splinck(x,inx,ilinx,1.0e-3,ierx)
157  if(ierx.ne.0) ier=2
158 c
159  if(ier.eq.2) then
160  write(6,'('' ?bcspline: x axis not strict ascending'')')
161  endif
162 c
163 c check ilinth & th vector
164 c
165  call splinck(th,inth,ilinth,1.0e-3,ierth)
166  if(ierth.ne.0) ier=3
167 c
168  if(ier.eq.3) then
169  write(6,'('' ?bcspline: th axis not strict ascending'')')
170  endif
171 c
172  if(ier.ne.0) return
173 c
174 c------------------------------------
175 c
176  xo2=0.5
177  xo6=1.0/6.0
178 c
179 c spline in x direction
180 c
181  inxo=4*(inx-1)
182  do ith=1,inth
183 c
184 c copy the function in
185 c
186  do ix=1,inx
187  wk(4*(ix-1)+1)=fspl(1,1,ix,ith)
188  enddo
189 c
190  if(ibcxmin.eq.1) then
191  wk(2)=bcxmin(ith)
192  else if(ibcxmin.eq.2) then
193  wk(3)=bcxmin(ith)
194  endif
195 c
196  if(ibcxmax.eq.1) then
197  wk(inxo+2)=bcxmax(ith)
198  else if(ibcxmax.eq.2) then
199  wk(inxo+3)=bcxmax(ith)
200  endif
201 c
202 c use Wayne's routine
203 c
204  call v_spline(ibcxmin,ibcxmax,inx,x,wk,wk(4*inx+1))
205 c
206 c copy the coefficients out
207 c
208  do ix=1,inx
209  fspl(2,1,ix,ith)=wk(4*(ix-1)+2)
210  fspl(3,1,ix,ith)=wk(4*(ix-1)+3)*xo2
211  fspl(4,1,ix,ith)=wk(4*(ix-1)+4)*xo6
212  enddo
213 c
214  enddo
215 c
216 c-----------------------------------
217 c
218 c spline in theta direction
219 c
220  intho=4*(inth-1)
221  do ix=1,inx
222 c
223 c spline each x coeff
224 c
225  do ic=1,4
226 c
227 c copy ordinates in
228 c
229  do ith=1,inth
230  wk(4*(ith-1)+1)=fspl(ic,1,ix,ith)
231  enddo
232 c
233 c first pass: use a linear BC -- if flag indicates BC correction
234 c will be needed, it will be done later
235 c
236  wk(2)=0.0
237  wk(3)=0.0
238  wk(intho+2)=0.0
239  wk(intho+3)=0.0
240 c
241  ibcthmina=ibcthmin
242  ibcthmaxa=ibcthmax
243  if(iflg2.eq.1) then
244  if((ibcthmin.eq.1).or.(ibcthmin.eq.2)) ibcthmina=0
245  if((ibcthmax.eq.1).or.(ibcthmax.eq.2)) ibcthmaxa=0
246  endif
247 c
248  call v_spline(ibcthmina,ibcthmaxa,inth,th,wk,wk(4*inth+1))
249 c
250 c copy coeffs out
251 c
252  do ith=1,inth
253  fspl(ic,2,ix,ith)=wk(4*(ith-1)+2)
254  fspl(ic,3,ix,ith)=wk(4*(ith-1)+3)*xo2
255  fspl(ic,4,ix,ith)=wk(4*(ith-1)+4)*xo6
256  enddo
257 c
258  enddo
259 c
260  enddo
261 c
262 c now make correction for user BC's if needed
263 c
264  if(iflg2.eq.1) then
265 c
266  iasc=1 ! wk addr for correction splines
267  iinc=4*inth ! spacing btw correction splines
268  iawk=iasc+4*inth*inx
269 c
270 c last grid zone widths
271 c
272  zhxn=x(inx)-x(inx-1)
273  jx=inx-1
274  zhth=th(inth)-th(inth-1)
275  jth=inth-1
276 c
277  do ii=1,10
278  iselect1(ii)=0
279  iselect2(ii)=0
280  enddo
281  if(ibcthmin.eq.1) iselect1(3)=1
282  if(ibcthmin.eq.2) iselect1(5)=1
283  if(ibcthmax.eq.1) iselect2(3)=1
284  if(ibcthmax.eq.2) iselect2(5)=1
285 c
286 c loop over BC's
287 c
288  do ix=1,inx
289 c
290 c (a) d/dth @ th(1) difference btw current BC and user request
291 c
292  if(ibcthmin.eq.1) then
293  if(ix.lt.inx) then
294  zcur(1)=fspl(1,2,ix,1) ! 1st deriv.
295  else
296  zcur(1)=fspl(1,2,jx,1)+zhxn*(fspl(2,2,jx,1)+zhxn*
297  > (fspl(3,2,jx,1)+zhxn*fspl(4,2,jx,1)))
298  endif
299  zdiff1=bcthmin(ix)-zcur(1)
300  else if(ibcthmin.eq.2) then
301  if(ix.lt.inx) then
302  zcur(1)=2.0*fspl(1,3,ix,1) ! 2nd deriv.
303  else
304  zcur(1)=2.0*
305  > (fspl(1,3,jx,1)+zhxn*(fspl(2,3,jx,1)+zhxn*
306  > (fspl(3,3,jx,1)+zhxn*fspl(4,3,jx,1))))
307  endif
308  zdiff1=bcthmin(ix)-zcur(1)
309  else
310  zdiff1=0.0
311  endif
312 c
313 c (b) d/dth @ th(inth) difference btw current BC and user request
314 c
315  if(ibcthmax.eq.1) then
316  if(ix.lt.inx) then
317 c 1st deriv.
318  zcur(1)=
319  > fspl(1,2,ix,jth)+zhth*(2.0*fspl(1,3,ix,jth)+
320  > zhth*3.0*fspl(1,4,ix,jth))
321  else
322  call bcspeval(x(inx),th(inth),iselect2, zcur,
323  > x,inx,th,inth,ilinx,ilinth,fspl,inf3,ier)
324  if(ier.ne.0) return
325  endif
326  zdiff2=bcthmax(ix)-zcur(1)
327  else if(ibcthmax.eq.2) then
328  if(ix.lt.inx) then
329 c 2nd deriv.
330  zcur(1)=2.0*fspl(1,3,ix,jth)+
331  > 6.0*zhth*fspl(1,4,ix,jth)
332  else
333  call bcspeval(x(inx),th(inth),iselect2, zcur(1),
334  > x,inx,th,inth,ilinx,ilinth,fspl,inf3,ier)
335  if(ier.ne.0) return
336  endif
337  zdiff2=bcthmax(ix)-zcur(1)
338  else
339  zdiff2=0.0
340  endif
341 c
342 c ok compute the theta spline with BC's to span the difference(s)
343 c these theta "correction splines" are zero at all the grid points
344 c but have at least one non-zero 1st or 2nd derivative BC
345 c
346  iadr=iasc+(ix-1)*iinc
347  do ith=1,inth
348  wk(iadr+4*(ith-1))=0.0
349  enddo
350 c
351  wk(iadr+1)=0.0
352  wk(iadr+2)=0.0
353  wk(iadr+intho+1)=0.0
354  wk(iadr+intho+2)=0.0
355 c
356  if(ibcthmin.eq.1) then
357  wk(iadr+1)=zdiff1
358  else if(ibcthmin.eq.2) then
359  wk(iadr+2)=zdiff1
360  endif
361 c
362  if(ibcthmax.eq.1) then
363  wk(iadr+intho+1)=zdiff2
364  else if(ibcthmax.eq.2) then
365  wk(iadr+intho+2)=zdiff2
366  endif
367 c
368  call v_spline(ibcthmin,ibcthmax,inth,th,wk(iadr),wk(iawk))
369  enddo
370 c
371 c add in results to main array -- th spline coef corrections
372 c
373  do ix=1,inx
374  iadr=iasc+(ix-1)*iinc
375  do ith=1,inth-1
376  wk(iadr+4*(ith-1)+2)=wk(iadr+4*(ith-1)+2)*xo2
377  wk(iadr+4*(ith-1)+3)=wk(iadr+4*(ith-1)+3)*xo6
378  if(ix.lt.inx) then
379  fspl(1,2,ix,ith)=fspl(1,2,ix,ith)+wk(iadr+4*(ith-1)+1)
380  fspl(1,3,ix,ith)=fspl(1,3,ix,ith)+wk(iadr+4*(ith-1)+2)
381  fspl(1,4,ix,ith)=fspl(1,4,ix,ith)+wk(iadr+4*(ith-1)+3)
382  endif
383  enddo
384  enddo
385 c
386 c compute the x splines of the th spline correction coeffs
387 c
388  ia5w=iawk+4*inx
389 c
390  do ith=1,inth-1
391  do ic=2,4
392  do ix=1,inx
393  iaspl=iasc+iinc*(ix-1)
394  wk(iawk+4*(ix-1))=wk(iaspl+4*(ith-1)+(ic-1))
395  enddo
396 c
397 c use zero BCs for this correction spline
398 c
399  wk(iawk+1)=0.0
400  wk(iawk+2)=0.0
401  wk(iawk+inxo+1)=0.0
402  wk(iawk+inxo+2)=0.0
403 c
404 c periodic spline of correction spline higher coeffs (1st coeffs are
405 c all zero by defn of the correction spline
406 c
407  call v_spline(ibcxmin,ibcxmax,inx,x,wk(iawk),wk(ia5w))
408 c
409  do ix=1,inx-1
410  fspl(2,ic,ix,ith)=fspl(2,ic,ix,ith)+
411  > wk(iawk+4*(ix-1)+1)
412  fspl(3,ic,ix,ith)=fspl(3,ic,ix,ith)+
413  > wk(iawk+4*(ix-1)+2)*xo2
414  fspl(4,ic,ix,ith)=fspl(4,ic,ix,ith)+
415  > wk(iawk+4*(ix-1)+3)*xo6
416  enddo
417 c
418  enddo
419  enddo ! ith
420 c
421  endif ! BC correction needs test
422 c
423  return
424  end