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