V3FIT
r8vecspline.f
1  subroutine r8vecspline(ict,ivec,xvec,ivd,fval,nx,xpkg,fspl,
2  > iwarn,ier)
3 c
4 c vectorized spline evaluation routine -- 1d *compact* spline
5 c 1. call vectorized zone lookup routine
6 c 2. call vectorized spline evaluation routine
7 c
8 c--------------------------
9 c input:
10  IMPLICIT NONE
11  INTEGER, PARAMETER :: R8=selected_real_kind(12,100)
12  integer ict(3) ! selector:
13 c ict(1)=1 for f (don't evaluate if ict(1)=0)
14 c ict(2)=1 for df/dx (don't evaluate if ict(2)=0)
15 c ict(3)=1 for d2f/dx2 (don't evaluate if ict(3)=0)
16 c
17  integer ivec ! vector dimensioning
18 c
19 c ivec-- number of vector pts (spline values to look up)
20 c
21  real*8 xvec(ivec) ! x-locations at which to evaluate
22 c
23  integer ivd ! 1st dimension of output array
24 c
25 c ivd -- 1st dimension of fval, .ge.ivec
26 c
27 c output:
28  real*8 fval(ivd,*) ! output array
29 c
30 c fval(1:ivec,1) -- values as per 1st non-zero ict(...) element
31 c fval(1:ivec,2) -- values as per 2nd non-zero ict(...) element
32 c --etc--
33 c
34 c input:
35  integer nx ! dimension of spline x grid
36  real*8 xpkg(nx,4) ! x grid "package" (cf genxpkg)
37  real*8 fspl(2,nx) ! (compact) spline coefficients
38 c
39 c output:
40 c condition codes, 0 = normal return
41  integer iwarn ! =1 if an x value was out of range
42  integer ier ! =1 if argument error detected
43 c
44 c---------------------------------------------------------------
45 c local arrays
46 c
47  integer iv(ivec) ! zone indices {j}
48  real*8 dxn(ivec) ! normalized displacements w/in zones
49  real*8 h(ivec) ! h(j) vector
50  real*8 hi(ivec) ! 1/h(j) vector
51 c
52 c---------------------------------------------------------------
53 c
54 c error checks
55 c
56  ier=0
57  if(nx.lt.2) then
58  write(6,*) .lt.' ?vecspline: nx2: nx = ',nx
59  ier=1
60  endif
61 c
62  if(ivec.le.0) then
63  write(6,*) .le.' ?vecspline: vector dimension 0: ivec = ',
64  > ivec
65  ier=1
66  endif
67 c
68  if(ivd.lt.ivec) then
69  write(6,*)
70  > ' ?vecspline: output vector dimension less than input ',
71  > 'vector dimension.'
72  write(6,*) ' ivec=',ivec,' ivd=',ivd
73  ier=1
74  endif
75 c
76  if(ier.ne.0) return
77 c
78 c vectorized lookup
79 c
80  iv=0
81  call r8xlookup(ivec,xvec,nx,xpkg,2,iv,dxn,h,hi,iwarn)
82 c
83 c vectorized evaluation
84 c
85  call r8fvspline(ict,ivec,ivd,fval,iv,dxn,h,hi,fspl,nx)
86 c
87  return
88  end