V3FIT
cspeval.f
1 c cspeval -- eval cubic spline function and/or derivatives
2 c
3  subroutine cspeval(xget,iselect,fval,x,nx,ilinx,f,ier)
4 c
5  real xget ! interpolation target
6  real fval(3) ! output values
7  real x(nx),f(4,nx) ! spline data
8 c
9  integer iselect(3) ! output selector
10  integer ilinx ! =1 if x(...) is evenly spaced
11 c
12 c modification -- dmc 11 Jan 1999 -- remove SAVE stmts; break routine
13 C into these parts:
14 C
15 C cspevx -- find grid cell of target pt.
16 C cspevfn -- evaluate function using output of bcpsevxy
17 C
18 C in cases where multiple functions are defined on the same grid,
19 C time can be saved by using cspevx once and then cspevfn
20 C multiple times.
21 c
22 c input:
23 c (xget) location where interpolated value is desired
24 c x(1).le.xget.le.x(nx) expected
25 c
26 c iselect select desired output
27 c
28 c iselect(1)=1 -- want function value (f) itself
29 c iselect(2)=1 -- want df/dx
30 c iselect(3)=1 -- want d2f/dx2
31 c
32 c example: iselect(1)=iselect(2)=iselect(3)=1
33 c f, df/dx, and d2f/dx2 are all evaluated
34 c and returned in order in fval(1), fval(2),
35 c and fval(3)
36 c iselect(1)=0, iselect(2)=1, iselect(3)=0
37 c only the 1st derivative is evaluated
38 c and returned in fval(1).
39 c
40 c set iselect(1)=3 to get d3f/dx3, 1 value only.
41 c
42 c see fval (output) description.
43 c
44 c x(1...nx) independent coordinate x, strict ascending
45 c
46 c ilinx -- =1: flag that x is linearly spaced (avoid search for speed)
47 c
48 c **CAUTION** actual even spacing of x, is NOT CHECKED HERE!
49 c
50 c f the function values (at grid points) and spline coefs
51 c
52 c evaluation formula: for point x btw x(i) and x(i+1), dx=x-x(i)
53 c
54 c spline value =
55 c f(1,i) + dx*f(2,i) + dx**2*f(3,i) + dx**3*f(4,i)
56 c
57 c output:
58 c up to 3 elements of fval, ordered as follows:
59 c fval(1)=function value or lowest order derivative requested
60 c fval(2)=next order derivative
61 c etc
62 c the ordering is a subset of the sequence given under the "iselect"
63 c description.
64 c
65 c ier = 0 -- successful completion; = 1 -- an error occurred.
66 c
67 c-------------------------------------------------------------------
68 c local
69 c
70  integer :: ia(1) = (/ 0 /)
71  real :: dxa(1)
72 c
73 c--------------------------
74 c
75  call cspevx(xget,x,nx,ilinx,ia(1),dxa(1),ier)
76  if(ier.ne.0) return
77 c
78  call cspevfn(iselect,1,1,fval,ia,dxa,f,nx)
79 c
80  return
81  end
82 c
83 c-------------------------------------------------------------------------
84 c cspevx -- look up x zone
85 c
86 c this is the "first part" of cspeval, see comments, above.
87 c
88  subroutine cspevx(xget,x,nx,ilinx,i,dx,ier)
89 c
90  integer nx ! x array dimension
91 c
92  real xget ! target point
93  real x(nx) ! independent coord. array
94 c
95  integer ilinx ! =1: assume x evenly spaced
96 c
97 c output of cspevx
98 c
99  integer i ! index to cell containing target pt
100  real dx ! displacement of target pt w/in cell
101  ! dx = x-x(i)
102 c
103 c the input argument range is checked...
104 c
105  integer ier ! return ier.ne.0 on error
106 c
107 c------------------------------------
108 c
109  ier=0
110 c
111 c range check
112 c
113  zxget=xget
114  if((xget.lt.x(1)).or.(xget.gt.x(nx))) then
115  zxtol=4.0e-7*max(abs(x(1)),abs(x(nx)))
116  if((xget.lt.x(1)-zxtol).or.(xget.gt.x(nx)+zxtol)) then
117  ier=1
118  write(6,1001) xget,x(1),x(nx)
119  1001 format(' ?cspeval: xget=',1pe11.4,' out of range ',
120  > 1pe11.4,' to ',1pe11.4)
121  else
122  if((xget.lt.x(1)-0.5*zxtol).or.
123  > (xget.gt.x(nx)+0.5*zxtol))
124  > write(6,1011) xget,x(1),x(nx)
125  1011 format(' %cspeval: xget=',1pe15.8,' beyond range ',
126  > 1pe15.8,' to ',1pe15.8,' (fixup applied)')
127  if(xget.lt.x(1)) then
128  zxget=x(1)
129  else
130  zxget=x(nx)
131  endif
132  endif
133  endif
134  if(ier.ne.0) return
135 c
136 c now find interval in which target point lies..
137 c
138  nxm=nx-1
139 c
140  if(ilinx.eq.1) then
141  ii=1+nxm*(zxget-x(1))/(x(nx)-x(1))
142  i=min(nxm, ii)
143  if(zxget.lt.x(i)) then
144  i=i-1
145  else if(zxget.gt.x(i+1)) then
146  i=i+1
147  endif
148  else
149  if((1.le.i).and.(i.lt.nxm)) then
150  if((x(i).le.zxget).and.(zxget.le.x(i+1))) then
151  continue ! already have the zone
152  else
153  call zonfind(x,nx,zxget,i)
154  endif
155  else
156  i=nx/2
157  call zonfind(x,nx,zxget,i)
158  endif
159  endif
160 c
161  dx=zxget-x(i)
162 c
163  return
164  end
165 c------------------------------------------------------------------------
166 c cspevfn -- OK now evaluate the cubic spline
167 c
168  subroutine cspevfn(ict,ivec,ivd,fval,iv,dxv,f,nx)
169 c
170 c input:
171  integer ict(3) ! selector:
172 c ict(1)=1 for f (don't evaluate f if ict(1)=0)
173 c ict(2)=1 for df/dx ""
174 c ict(3)=1 for d2f/dx2
175 c
176 c set ict(1)=3 to get d3f/dx3 (only)
177 c
178  integer ivec,ivd ! vector dimensioning
179 c
180 c ivec-- number of vector pts (spline values to look up)
181 c ivd -- 1st dimension of fval, .ge.ivec
182 c
183 c output:
184  real fval(ivd,*) ! output array
185 c
186 c v = index to element in vector;
187 c fval(v,1) = first item requested by ict(...),
188 c fval(v,2) = 2nd item requested, ...etc...
189 c
190 c input:
191  integer iv(ivec) ! grid cell indices -- vectors
192  real dxv(ivec) ! displacements w/in cell -- vectors
193 c
194  real f(4,nx) ! cubic fcn spline coeffs array
195 c
196 c usage example:
197 c
198 c 1. for each element xx(v) in a vector of x values:
199 c find the x zone index and displacement with respect to the
200 c lower end point of the zone; store thes in vectors iv and dxv.
201 c
202 c 2. set ict(1)=0, ict(2)=1, ict(3)=0 -- get only the 1st derivative
203 c
204 c 3. ivec is the length of the vector; ivd is the 1st dimension of the
205 c array fval to receive the output
206 c
207 c real fval(ivd,3)
208 c real xv(ivd)
209 c real dxv(ivd)
210 c integer iv(ivd)
211 c integer ict(3)
212 c
213 c real fspline(4,nx) ! spline coeffs
214 c data ict/0,1,0/ ! this call: want 1st derivative only
215 c ! this will be output to fval(*,1).
216 c ...
217 c do iv=1,ivec
218 c ... ! comput indices & displacements
219 c enddo
220 c call cspevfn(ict,ivec,ivd,fval,iv,dxv,fspline,nx)
221 c
222 c--------------------------------------------------------------------
223 c local:
224 c
225  integer v ! vector element index
226 c
227 c OK can now do evaluations
228 c
229  iaval=0 ! fval addressing
230 c
231  if(ict(1).eq.3) then
232 c
233 c fxxx = d3f/dx3
234 c
235  iaval=iaval+1
236  do v=1,ivec
237  i=iv(v)
238  fval(v,iaval)=6.0*f(4,i)
239  enddo
240  else
241 c
242 c normal call...
243 c
244  if(ict(1).gt.0) then
245 c evaluate f
246  iaval=iaval+1
247  do v=1,ivec
248  i=iv(v)
249  dx=dxv(v)
250  fval(v,iaval)=f(1,i)+dx*(f(2,i)+dx*(f(3,i)+dx*f(4,i)))
251  enddo
252  endif
253 c
254  if(ict(2).gt.0) then
255 c evaluate df/dx
256  iaval=iaval+1
257  do v=1,ivec
258  i=iv(v)
259  dx=dxv(v)
260  fval(v,iaval)=f(2,i)+dx*(2.0*f(3,i)+dx*3.0*f(4,i))
261  enddo
262  endif
263 c
264  if(ict(3).gt.0) then
265 c evaluate d2f/dx2
266  iaval=iaval+1
267  do v=1,ivec
268  i=iv(v)
269  dx=dxv(v)
270  fval(v,iaval)=2.0*f(3,i)+dx*6.0*f(4,i)
271  enddo
272  endif
273  endif
274 c
275  return
276  end
277 c----------------------