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