V3FIT
vecherm1.f
1  subroutine vecherm1(ict,ivec,xvec,ivd,fval,nx,xpkg,fspl,
2  > iwarn,ier)
3 c
4 c vectorized hermite evaluation routine -- 1d
5 c 1. call vectorized zone lookup routine
6 c 2. call vectorized hermite evaluation routine
7 c
8 c--------------------------
9 c input:
10  integer ict(2) ! selector:
11 c ict(1)=1 for f (don't evaluate if ict(1)=0)
12 c ict(2)=1 for df/dx (don't evaluate if ict(2)=0)
13 c
14  integer ivec ! vector dimensioning
15 c
16 c ivec-- number of vector pts (hermite values to look up)
17 c
18  real xvec(ivec) ! x-locations at which to evaluate
19 c
20  integer ivd ! 1st dimension of output array
21 c
22 c ivd -- 1st dimension of fval, .ge.ivec
23 c
24 c output:
25  real fval(ivd,*) ! output array
26 c
27 c fval(1:ivec,1) -- values as per 1st non-zero ict(...) element
28 c fval(1:ivec,2) -- values as per 2nd non-zero ict(...) element
29 c --etc--
30 c
31 c input:
32  integer nx ! dimension of hermite x grid
33  real xpkg(nx,4) ! x grid "package" (cf genxpkg)
34  real fspl(2,nx) ! Hermite coefficients (cf herm1ev)
35 c
36 c output:
37 c condition codes, 0 = normal return
38  integer iwarn ! =1 if an x value was out of range
39  integer ier ! =1 if argument error detected
40 c
41 c---------------------------------------------------------------
42 c local arrays
43 c
44  integer iv(ivec) ! zone indices {j}
45  real dxn(ivec) ! normalized displacements w/in zones
46  real h(ivec) ! h(j) vector
47  real hi(ivec) ! 1/h(j) vector
48 c
49 c---------------------------------------------------------------
50 c
51 c error checks
52 c
53  ier=0
54  if(nx.lt.2) then
55  write(6,*) .lt.' ?vecherm1: nx2: nx = ',nx
56  ier=1
57  endif
58 c
59  if(ivec.le.0) then
60  write(6,*) .le.' ?vecherm1: vector dimension 0: ivec = ',
61  > ivec
62  ier=1
63  endif
64 c
65  if(ivd.lt.ivec) then
66  write(6,*)
67  > ' ?vecherm1: output vector dimension less than input ',
68  > 'vector dimension.'
69  write(6,*) ' ivec=',ivec,' ivd=',ivd
70  ier=1
71  endif
72 c
73  if(ier.ne.0) return
74 c
75 c vectorized lookup
76 c
77  iv=0
78  call xlookup(ivec,xvec,nx,xpkg,2,iv,dxn,h,hi,iwarn)
79 c
80 c vectorized evaluation
81 c
82  call herm1fcn(ict,ivec,ivd,fval,iv,dxn,h,hi,fspl,nx)
83 c
84  return
85  end