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