V3FIT
spline_cubic_int.f
1  subroutine spline_cubic_int(x,y,xx,yy,n,iflag)
2  USE stel_kinds
3  implicit none
4 !----------------------------------------------------------------------
5 ! iflag = 0 normal return
6 ! iflag =-1 x-request outside of bounds
7 ! iflag =-2 xx arrays with two equal entries or not in correct order
8 !----------------------------------------------------------------------
9 !-----------------------------------------------
10 ! D u m m y A r g u m e n t s
11 !-----------------------------------------------
12  integer, intent(in) :: n
13  integer, intent(inout) :: iflag
14  real(rprec), intent(in) :: x
15  real(rprec), dimension(n), intent(in) :: xx,yy
16  real(rprec), intent(out) :: y
17  real(rprec), dimension(n) :: y2, dxx
18 !-----------------------------------------------
19 ! L o c a l V a r i a b l e s
20 !-----------------------------------------------
21  real(rprec) :: yp1, ypn
22  real(rprec) :: c
23 !-----------------------------------------------
24 
25  iflag = 0 !initialization
26  if(x < xx(1) .or. x > xx(n)) then
27  iflag = -1
28  y=0.d+0
29  return
30  endif
31  dxx(1:n-1)=xx(2:n)-xx(1:n-1)
32  if(minval(dxx(1:n-1)) <= 0.d+0) then
33  iflag=-2
34  return
35  endif
36 
37 ! fix boundary derivatives by quadratic fit
38 ! left part
39  c=((yy(3)-yy(1))/(xx(3)-xx(1))-(yy(2)-yy(1))/(xx(2)-xx(1)))
40  > /(xx(3)-xx(2))
41  yp1=(yy(2)-yy(1))/(xx(2)-xx(1))-c*(xx(2)-xx(1))
42 ! right part
43  c=((yy(n-2)-yy(n))/(xx(n-2)-xx(n))
44  > -(yy(n-1)-yy(n))/(xx(n-1)-xx(n)))
45  > /(xx(n-2)-xx(n-1))
46  ypn=(yy(n-1)-yy(n))/(xx(n-1)-xx(n))-c*(xx(n-1)-xx(n))
47 
48  call spline_int(xx,yy,n,yp1,ypn,y2)
49  call splint_int(xx,yy,y2,n,x,y)
50 
51  return
52 
53  contains
54 
55  subroutine spline_int(x,y,n,yp1,ypn,y2)
56 ! taken from numerical recipes f77 and recoded.
57 ! Given the arrays x(1:n) and y(1:n) containing the tabulated function
58 ! with x(1) < x(2) <...< x(n) and given values yp1 and ypn for the first
59 ! derivative of the interpolating function at points q and n, respectively,
60 ! this routine returns an array y2(1:n) of length n which contains the
61 ! second derivatives of the interpolating function at the tabulated points x(i).
62 ! If yp1 and/or ypn are equatl to 1ed+30 or larger, the routine is signaled
63 ! to set the correspoinding boundary condition for a natural spline with zero
64 ! derivative on that boundary.
65 ! nmax is the largest anticipated value of n.
66  integer, intent(in) :: n
67  integer, parameter :: nmax=500
68  real(rprec), intent(in) :: yp1, ypn
69  real(rprec), dimension(n), intent(in) :: x, y
70  real(rprec), dimension(n), intent(out) :: y2
71  integer :: i,k
72  real(rprec) :: p, qn, sig, un
73  real(rprec), dimension(n) :: u
74 
75  if(yp1 > .99d+30) then
76  y2(1)=0.d+0
77  u(1) =0.d+0
78  else
79  y2(1)=-0.5d+0
80  u(1)=(3.d+0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
81  endif
82 
83  do i=2,n-1
84  sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
85  p=sig*y2(i-1)+2.d+0
86  y2(i)=(sig-1.d+0)/p
87  u(i)=(6.d+0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
88  > /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
89  enddo
90  if (ypn > .99d+30)then
91  qn=0.d+0
92  un=0.d+0
93  else
94  qn=0.5d+0
95  un=(3.d+0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
96  endif
97  y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.d+0)
98  do k=n-1,1,-1
99  y2(k)=y2(k)*y2(k+1)+u(k)
100  enddo
101  return
102  end subroutine spline_int
103 
104  subroutine splint_int(xa,ya,y2a,n,x,y)
105 ! Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a function
106 ! with the xa(i)'s in order), and given the array y2a(1:n), which is the
107 ! output from spline above, and given a value of x, this routine returns
108 ! a cubic-spline interpolated value y.
109  implicit none
110  integer, intent(in) :: n
111  real(rprec), intent(in) :: x
112  real(rprec), intent(out) :: y
113  real(rprec), dimension(n), intent(in) :: xa, ya, y2a
114 !- local -------------------
115  real(rprec) :: h, c, dx
116  integer :: k, khi, klo
117  real(rprec), dimension(n) :: dxa,dxa3, dya, dy2a, my2a, mya
118 
119  klo=1
120  khi=n
121  do
122  if (khi-klo <= 1) exit !inverted num.rec. condition for endless do-loop exit
123  k=(khi+klo)/2
124  if(xa(k) > x) then
125  khi=k
126  else
127  klo=k
128  endif
129  enddo
130 
131  dxa(1:n-1)=xa(2:n)-xa(1:n-1)
132  dxa3=dxa**3
133  dya(1:n-1)=ya(2:n)-ya(1:n-1)
134  mya(1:n-1)=ya(2:n)+ya(1:n-1)
135  dy2a(1:n-1)=y2a(2:n)-y2a(1:n-1)
136  my2a(1:n-1)=y2a(2:n)+y2a(1:n-1)
137 ! integral up to specific interval [klo:khi] in which x is.
138  c = .5d+0*dot_product(dxa(1:klo-1),mya(1:klo-1))
139  > -dot_product(dxa3(1:klo-1),my2a(1:klo-1))/24.0d+0
140  h=xa(khi)-xa(klo)
141  if(h ==0.d+0)
142  > stop "spline_cubic: bad xa input! xa(i) have to be distinct!"
143  dx=x-xa(klo)
144  y = ya(klo)*dx +.5d+0*dya(klo)*dx**2/h +
145  > y2a(klo)*dx**2*(2*dx-3*h)/12.d+0 +
146  > dy2a(klo)*dx**2*(dx**2-2*h**2)/(h*24.d+0)
147  y= y+c
148  return
149  end subroutine splint_int
150 
151  end subroutine spline_cubic_int
152