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