V3FIT
r8tcspvec.f
1  subroutine r8tcspvec(ict,ivec,xvec,yvec,zvec,ivd,fval,
2  > nx,xpkg,ny,ypkg,nz,zpkg,fspl,inf4,inf5,
3  > iwarn,ier)
4 c
5 c vectorized spline evaluation routine -- 3d 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,iwarn3
16 !============
17 ! idecl: explicitize implicit REAL declarations:
18  real*8 stat
19 !============
20  integer ict(10) ! selector:
21 c ict(1)=1 for f (don't evaluate if ict(1)=0)
22 c ict(2)=1 for df/dx (don't evaluate if ict(2)=0)
23 c ict(3)=1 for df/dy (don't evaluate if ict(3)=0)
24 c ict(4)=1 for df/dy (don't evaluate if ict(4)=0)
25 c ict(5)=1 for d2f/dx2 (don't evaluate if ict(5)=0)
26 c ict(6)=1 for d2f/dy2 (don't evaluate if ict(6)=0)
27 c ict(7)=1 for d2f/dz2 (don't evaluate if ict(7)=0)
28 c ict(8)=1 for d2f/dxdy (don't evaluate if ict(8)=0)
29 c ict(9)=1 for d2f/dxdz (don't evaluate if ict(9)=0)
30 c ict(10)=1 for d2f/dydz (don't evaluate if ict(10)=0)
31 c
32  integer ivec ! vector dimensioning
33 c
34 c ivec-- number of vector pts (spline values to look up)
35 c
36 c list of (x,y,z) triples:
37 c
38  real*8 xvec(ivec) ! x-locations at which to evaluate
39  real*8 yvec(ivec) ! y-locations at which to evaluate
40  real*8 zvec(ivec) ! z-locations at which to evaluate
41 c
42  integer ivd ! 1st dimension of output array
43 c
44 c ivd -- 1st dimension of fval, .ge.ivec
45 c
46 c output:
47  real*8 fval(ivd,*) ! output array
48 c
49 c fval(1:ivec,1) -- values as per 1st non-zero ict(...) element
50 c fval(1:ivec,2) -- values as per 2nd non-zero ict(...) element
51 c --etc--
52 c
53 c input:
54  integer nx,ny,nz ! dimension of spline grids
55  REAL*8 xpkg(nx,4) ! x grid "package" (cf genxpkg)
56  real*8 ypkg(ny,4) ! y grid "package" (cf genxpkg)
57  real*8 zpkg(nz,4) ! z grid "package" (cf genxpkg)
58  integer inf4 ! fspl 4th array dimension, .ge.nx
59  integer inf5 ! fspl 5th array dimension, .ge.ny
60  real*8 fspl(4,4,4,inf4,inf5,nz) ! (non-compact) spline coefficients
61 c
62 c output:
63 c condition codes, 0 = normal return
64  integer iwarn ! =1 if an x value was out of range
65  integer ier ! =1 if argument error detected
66 c
67 c---------------------------------------------------------------
68 c local arrays
69 c
70  integer, dimension(:), allocatable :: ix,iy,iz
71  REAL*8, dimension(:), allocatable :: dxv,dyv,dzv
72 c
73 c---------------------------------------------------------------
74 c
75 c error checks
76 c
77  ier=0
78 c
79  if(nx.lt.2) then
80  write(6,*) .lt.' ?tcspvec: nx2: nx = ',nx
81  ier=1
82  endif
83 c
84  if(ny.lt.2) then
85  write(6,*) .lt.' ?tcspvec: ny2: ny = ',ny
86  ier=1
87  endif
88 c
89  if(nz.lt.2) then
90  write(6,*) .lt.' ?tcspvec: nz2: nz = ',nz
91  ier=1
92  endif
93 c
94  if(ivec.le.0) then
95  write(6,*) .le.' ?tcspvec: vector dimension 0: ivec = ',
96  > ivec
97  ier=1
98  endif
99 c
100  if(ivd.lt.ivec) then
101  write(6,*)
102  > ' ?tcspvec: output vector dimension less than input ',
103  > 'vector dimension.'
104  write(6,*) ' ivec=',ivec,' ivd=',ivd
105  ier=1
106  endif
107 c
108  if(ier.ne.0) return
109 c
110  allocate(ix(ivec), iy(ivec), iz(ivec),
111  > dxv(ivec), dyv(ivec), dzv(ivec), stat=ier)
112 c
113  if(ier.ne.0) then
114  write(6,*)
115  > ' ?tcspvec: memory allocation failure.'
116  ier=99
117  endif
118 c
119  if(ier.ne.0) return
120 c
121 c vectorized lookups
122 c
123  ix=0; iy=0; iz=0
124  call r8xlookup(ivec,xvec,nx,xpkg,1,ix,dxv,dxv,dxv,iwarn1)
125  call r8xlookup(ivec,yvec,ny,ypkg,1,iy,dyv,dyv,dyv,iwarn2)
126  call r8xlookup(ivec,zvec,nz,zpkg,1,iz,dzv,dzv,dzv,iwarn3)
127  iwarn=max(iwarn1,iwarn2,iwarn3)
128 c
129 c vectorized evaluation
130 c
131  call r8tcspevfn(ict,ivec,ivd,fval,ix,iy,iz,dxv,dyv,dzv,
132  > fspl,inf4,inf5,nz)
133 c
134  deallocate(ix,iy,iz,dxv,dyv,dzv)
135 c
136  return
137  end