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