spline.F90 coverage: 0.00 %func 0.00 %block
1) module spline_module
2)
3) #include "petsc/finclude/petscsys.h"
4)
5) public
6)
7) contains
8)
9) ! ************************************************************************** !
10)
11) subroutine spline(x,y,n,y2)
12)
13)
14) !----------------------description-------------------------------------!
15) !
16) ! cubic spline second derivative.
17) !
18) ! press, w.h., b.p. flannery, s.a. teukolsky, and w.t. vetterling.
19) ! 1986. numerical recipes, the art of scientific computing,
20) ! cambridge university press, cambridge. pp. 86-89.
21)
22) use PFLOTRAN_Constants_module
23)
24) implicit none
25)
26) PetscInt :: i,n,k
27) PetscReal :: x(n),y(n),y2(n),u(n)
28) PetscReal :: sig,p,qn,un
29)
30) y2(1) = 0.d0
31) u(1) = 0.d0
32) do i = 2,n-1
33) sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
34) p = sig*y2(i-1)+2.d0
35) y2(i) = (sig-1.d0)/p
36) u(i) = (6.d0*((y(i+1)-y(i))/(x(i+1)-x(i)) - &
37) (y(i)-y(i-1))/(x(i)-x(i-1)))/ &
38) (x(i+1)-x(i-1)) - sig*u(i-1))/p
39) enddo
40) qn = 0.d0
41) un = 0.d0
42) y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.d0)
43) do k = n-1,1,-1
44) y2(k) = y2(k)*y2(k+1)+u(k)
45) enddo
46)
47) return
48) end subroutine spline
49)
50) ! ************************************************************************** !
51)
52) subroutine splint(xa,ya,y2a,n,x,y)
53)
54) ! cubic spline interpolation.
55)
56) ! press, w.h., b.p. flannery, s.a. teukolsky, and w.t. vetterling.
57) ! 1986. numerical recipes, the art of scientific computing,
58) ! cambridge university press, cambridge. pp. 86-89.
59)
60)
61) implicit none
62) PetscInt :: n,k,klo,khi
63) PetscReal :: xa(n),ya(n),y2a(n)
64) PetscReal :: h,a,b,x,y
65)
66) klo = 1
67) khi = n
68) 10 continue
69) if (khi-klo.gt.1) then
70) k = (khi+klo)/2
71) if (xa(k).gt.x) then
72) khi = k
73) else
74) klo = k
75) endif
76) goto 10
77) endif
78) h = xa(khi)-xa(klo)
79) a = (xa(khi)-x)/h
80) b = (x-xa(klo))/h
81) y = a*ya(klo)+b*ya(khi)+ &
82) ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.d0
83) ! y1a = (ya(khi)-ya(klo))/h - &
84) ! ((3.d+0*(a**2)-1.d+0)/6.d+0)*h*y2a(klo) + &
85) ! ((3.d+0*(b**2)-1.d+0)/6.d+0)*h*y2a(khi)
86)
87) return
88) end subroutine splint
89)
90) ! ************************************************************************** !
91)
92) subroutine locate(xx,n,x,j)
93)
94) ! given an array xx of length n, and given a value x, returns a
95) ! value j such that x is between xx(j) and xx(j+1). xx must be
96) ! monotonic, either increasing or decreasing. j=0 or j=n is
97) ! returned to indicate that x is out of range.
98) !
99) ! press, w.h., b.p. flannery, s.a. teukolsky, and w.t. vetterling.
100) ! 1986. numerical recipes, the art of scientific computing.
101) ! cambridge university press, cambridge.
102)
103) implicit none
104) PetscInt :: jl,ju,jm,j,n
105) PetscReal :: xx(n)
106) PetscReal :: x
107)
108) jl = 0
109) ju = n+1
110) 10 continue
111) if (ju-jl.gt.1) then
112) jm = (ju+jl)/2
113) if ((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm))) then
114) jl = jm
115) else
116) ju = jm
117) endif
118) goto 10
119) endif
120) j = jl
121)
122) return
123) end subroutine locate
124)
125) end module spline_module