V3FIT
r8bcspvec.f
1  subroutine r8bcspvec(ict,ivec,xvec,yvec,ivd,fval,
2  > nx,xpkg,ny,ypkg,fspl,inf3,
3  > iwarn,ier)
4 c
5 c vectorized spline evaluation routine -- 2d spline
6 c 1. call vectorized zone lookup routine
7 c 2. call vectorized spline evaluation routine
8 c
9 c--------------------------
10 c input:
11 !============
12 ! idecl: explicitize implicit INTEGER declarations:
13  IMPLICIT NONE
14  INTEGER, PARAMETER :: R8=selected_real_kind(12,100)
15  INTEGER iwarn1,iwarn2
16 !============
17  integer ict(6) ! selector:
18 c ict(1)=1 for f (don't evaluate if ict(1)=0)
19 c ict(2)=1 for df/dx (don't evaluate if ict(2)=0)
20 c ict(3)=1 for df/dy (don't evaluate if ict(3)=0)
21 c ict(4)=1 for d2f/dx2 (don't evaluate if ict(4)=0)
22 c ict(5)=1 for d2f/dy2 (don't evaluate if ict(5)=0)
23 c ict(6)=1 for d2f/dxdy (don't evaluate if ict(6)=0)
24 c
25  integer ivec ! vector dimensioning
26 c
27 c ivec-- number of vector pts (spline values to look up)
28 c
29 c list of (x,y) pairs:
30 c
31  real*8 xvec(ivec) ! x-locations at which to evaluate
32  real*8 yvec(ivec) ! y-locations at which to evaluate
33 c
34  integer ivd ! 1st dimension of output array
35 c
36 c ivd -- 1st dimension of fval, .ge.ivec
37 c
38 c output:
39  real*8 fval(ivd,*) ! output array
40 c
41 c fval(1:ivec,1) -- values as per 1st non-zero ict(...) element
42 c fval(1:ivec,2) -- values as per 2nd non-zero ict(...) element
43 c --etc--
44 c
45 c input:
46  integer nx,ny ! dimension of spline grids
47  REAL*8 xpkg(nx,4) ! x grid "package" (cf genxpkg)
48  real*8 ypkg(ny,4) ! y grid "package" (cf genxpkg)
49  integer inf3 ! fspl 3rd array dimension, .ge.nx
50  real*8 fspl(4,4,inf3,ny) ! (non-compact) spline coefficients
51 c
52 c output:
53 c condition codes, 0 = normal return
54  integer iwarn ! =1 if an x value was out of range
55  integer ier ! =1 if argument error detected
56 c
57 c---------------------------------------------------------------
58 c local arrays
59 c
60  integer ix(ivec) ! x zone indices
61  REAL*8 dxv(ivec) ! x displacements w/in zones
62  integer iy(ivec) ! y zone indices
63  real*8 dyv(ivec) ! y displacements w/in zones
64 c
65 c---------------------------------------------------------------
66 c
67 c error checks
68 c
69  ier=0
70 c
71  if(nx.lt.2) then
72  write(6,*) .lt.' ?bcspvec: nx2: nx = ',nx
73  ier=1
74  endif
75 c
76  if(ny.lt.2) then
77  write(6,*) .lt.' ?bcspvec: ny2: ny = ',ny
78  ier=1
79  endif
80 c
81  if(ivec.le.0) then
82  write(6,*) .le.' ?bcspvec: vector dimension 0: ivec = ',
83  > ivec
84  ier=1
85  endif
86 c
87  if(ivd.lt.ivec) then
88  write(6,*)
89  > ' ?bcspvec: output vector dimension less than input ',
90  > 'vector dimension.'
91  write(6,*) ' ivec=',ivec,' ivd=',ivd
92  ier=1
93  endif
94 c
95  if(ier.ne.0) return
96 c
97 c vectorized lookups
98 c
99  ix=0
100  iy=0
101  call r8xlookup(ivec,xvec,nx,xpkg,1,ix,dxv,dxv,dxv,iwarn1)
102  call r8xlookup(ivec,yvec,ny,ypkg,1,iy,dyv,dyv,dyv,iwarn2)
103  iwarn=max(iwarn1,iwarn2)
104 c
105 c vectorized evaluation
106 c
107  call r8bcspevfn(ict,ivec,ivd,fval,ix,iy,dxv,dyv,fspl,inf3,ny)
108 c
109  return
110  end