V3FIT
r8vecherm2.f
1  subroutine r8vecherm2(ict,ivec,xvec,yvec,ivd,fval,
2  > nx,xpkg,ny,ypkg,fspl,inf2,
3  > iwarn,ier)
4 c
5 c vectorized hermite evaluation routine -- 2d
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
16 !============
17  integer ict(4) ! 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/dxdy (don't evaluate if ict(4)=0)
22 c
23  integer ivec ! vector dimensioning
24 c
25 c ivec-- number of vector pts (hermite values to look up)
26 c
27 c list of (x,y) pairs:
28 c
29  real*8 xvec(ivec) ! x-locations at which to evaluate
30  real*8 yvec(ivec) ! y-locations at which to evaluate
31 c
32  integer ivd ! 1st dimension of output array
33 c
34 c ivd -- 1st dimension of fval, .ge.ivec
35 c
36 c output:
37  real*8 fval(ivd,*) ! output array
38 c
39 c fval(1:ivec,1) -- values as per 1st non-zero ict(...) element
40 c fval(1:ivec,2) -- values as per 2nd non-zero ict(...) element
41 c --etc--
42 c
43 c input:
44  integer nx,ny ! dimension of hermite grids
45  REAL*8 xpkg(nx,4) ! x grid "package" (cf genxpkg)
46  real*8 ypkg(ny,4) ! y grid "package" (cf genxpkg)
47  integer inf2 ! fspl 3rd array dimension, .ge.nx
48  real*8 fspl(0:3,inf2,ny) ! Hermite coefficients, cf herm2ev
49 c
50 c output:
51 c condition codes, 0 = normal return
52  integer iwarn ! =1 if an x value was out of range
53  integer ier ! =1 if argument error detected
54 c
55 c---------------------------------------------------------------
56 c local arrays
57 c
58  integer ix(ivec) ! zone indices {j}
59  REAL*8 dxn(ivec) ! normalized displacements w/in zones
60  real*8 hx(ivec) ! h(j) vector
61  real*8 hxi(ivec) ! 1/h(j) vector
62 c
63  integer iy(ivec) ! zone indices {j}
64  REAL*8 dyn(ivec) ! normalized displacements w/in zones
65  real*8 hy(ivec) ! h(j) vector
66  real*8 hyi(ivec) ! 1/h(j) vector
67 c
68 c---------------------------------------------------------------
69 c
70 c error checks
71 c
72  ier=0
73 c
74  if(nx.lt.2) then
75  write(6,*) .lt.' ?vecherm2: nx2: nx = ',nx
76  ier=1
77  endif
78 c
79  if(ny.lt.2) then
80  write(6,*) .lt.' ?vecherm2: ny2: ny = ',ny
81  ier=1
82  endif
83 c
84  if(ivec.le.0) then
85  write(6,*) .le.' ?vecherm2: vector dimension 0: ivec = ',
86  > ivec
87  ier=1
88  endif
89 c
90  if(ivd.lt.ivec) then
91  write(6,*)
92  > ' ?vecherm2: output vector dimension less than input ',
93  > 'vector dimension.'
94  write(6,*) ' ivec=',ivec,' ivd=',ivd
95  ier=1
96  endif
97 c
98  if(ier.ne.0) return
99 c
100 c vectorized lookup
101 c
102  ix=0
103  iy=0
104  call r8xlookup(ivec,xvec,nx,xpkg,2,ix,dxn,hx,hxi,iwarn1)
105  call r8xlookup(ivec,yvec,ny,ypkg,2,iy,dyn,hy,hyi,iwarn2)
106  iwarn=iwarn1+iwarn2
107 c
108 c vectorized evaluation
109 c
110  call r8herm2fcn(ict,ivec,ivd,fval,ix,iy,dxn,dyn,
111  > hx,hxi,hy,hyi,fspl,inf2,ny)
112 c
113  return
114  end