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