!// 四類三次樣條插值
!// 1.自然三次樣條插值; 2.鉗制三次樣條插值; 3.曲率(二階導數)任意調整的三次樣條插值; 4.拋物線端點的三次樣條曲線; 5.非紐結三次樣條(matlab中的命令爲spline)
Module CalSpline
Implicit none
Character(*), parameter :: file1 = 'xy.txt' !// 插值基點文件
Real(kind=8), allocatable :: x(:), y(:) !// 已知節點
Real(kind=8), allocatable :: coeff(:,:) !// 係數矩陣b,c,d
Real(kind=8), allocatable :: a(:,:), r(:,:) !// a爲求解係數c的左端項係數矩陣, r爲求解係數c的右端項
Real(kind=8), allocatable :: segma(:), delta(:) !// segma(i) = x(i+1) - x(i), delta(i) = y(i+1) - y(i), i = 1,...,numLine-1
Integer :: numLine
Contains
Subroutine CalFileLine ()
Implicit none
Integer, parameter :: fileid = 101
Integer :: info = 0, i
!//---------讀取節點數據個數---------
numLine = 0
Open ( fileid, file = file1 )
Do
Read ( fileid, fmt = *, iostat = info )
If ( info /= 0 ) Exit
numLine = numLine + 1
End Do
print*, 'numLine:'
print*, numLine
Allocate( x(numLine), y(numLine), stat = info )
If ( info == 0 ) Then
Write ( *,'(1x,g0)' ) "Allocate x, y array successfully!"
Else
Write ( *,'(1x,g0)' ) "Allocate x, y array fail!"
End if
!//---------讀取xy---------
rewind ( fileid )
print*, 'array xy:'
Do i = 1, numLine
Read ( fileid,* ) x(i), y(i)
print*, x(i), y(i)
End Do
Close ( fileid )
End subroutine CalFileLine
Subroutine Calcoeff ()
Use lapack95 !// 使用lapack函數庫求解逆矩陣
Implicit none
Integer :: info = 0, i
Real(kind=8) :: tmp_a(numLine,numLine), tmp_r(numLine,1)
Real(kind=8) :: v1 = 0.d0, vn = 0.d0 !// v1, vn是兩個端點的一階導數，由用戶自行設定，用於鉗制三次樣條插值.(這裏爲了方便，v1,vn在代碼裏也可以用於曲率調整的三次樣條)
!//---------分配數組---------
Allocate( segma(numLine-1), delta(numLine-1), coeff(numLine,3), a(numLine,numLine), r(numLine,1), stat = info )
segma = 0.d0; delta = 0.d0
coeff = 0.d0; a = 0.d0; r = 0.d0
If ( info == 0 ) Then
Write ( *,'(1x,g0)' ) "Allocate array successfully!"
Else
Write ( *,'(1x,g0)' ) "Allocate array fail!"
End if
!//---------計算segma與delta---------
Do i = 1, numLine - 1
segma(i) = x(i+1) - x(i)
delta(i) = y(i+1) - y(i)
End Do
!//---------構建求取係數c的左端項矩陣a與右端項r---------
! a(1,1) = 1.d0; a(numLine,numLine) = 1.d0
! r(1,1) = 0.d0; r(numLine,1) = 0.d0 !// 自然三次樣條Nature cubic spline: 兩端點處的二階導數爲0
! a(1,1:2) = [ 2.d0 * segma(1), segma(1) ]; a(numLine,numLine-1:numLine) = [ segma(numLine-1), 2.d0 * segma(numLine-1) ]
! r(1,1) = 3.d0 * ( delta(1) / segma(1) - v1 ); r(numLine,1) = 3.d0 * ( vn - delta(numLine-1) / segma(numLine-1) ) !// 鉗制三次樣條插值，兩端點處的一階導數爲0
! a(1,1) = 2.d0; a(numLine,numLine) = 2.d0
! r(1,1) = v1; r(numLine,1) = vn !// 曲率(二階導數)任意調整的三次樣條插值，這裏的v1,vn爲兩端點的二階導數(曲率)
! a(1,1:2) = [ 1.d0, -1.d0 ]; a(numLine,numLine-1:numLine) = [ 1.d0, -1.d0 ]
! r(1,1) = 0.d0; r(numLine,1) = 0.d0 !// 拋物線端點的三次樣條曲線，通過使三次項的係數爲0，得樣條的起始和結束部分S1和Sn-1至多2階
a(1,1:3) = [ segma(2), -( segma(1) + segma(2) ), segma(1) ]; a(numLine,numLine-2:numLine) = [ segma(numLine-1), -( segma(numLine-2) + segma(numLine-1) ), segma(numLine-2) ]
r(1,1) = 0.d0; r(numLine,1) = 0.d0 !// 非紐結三次樣條(X2,Xn-1爲非紐結點)
Do i = 2, numLine - 1
a( i,i-1:i+1 ) = [ segma(i-1), 2.d0* ( segma(i-1) + segma(i) ), segma(i) ] !// 左端項係數矩陣
r( i,1 ) = 3.d0 * ( delta(i) / segma(i) - delta(i-1) / segma(i-1) ) !// 右端項係數矩陣
End Do
!//---------計算係數c---------
tmp_a = a; tmp_r = r
call gesv( tmp_a, tmp_r ) !// 使用lapack函數庫
coeff(:,2) = tmp_r(:,1)
!//---------計算係數b,d---------
Do i = 1, numLine - 1
coeff(i,1) = delta(i) / segma(i) - segma(i) * ( 2.d0*coeff(i,2) + coeff(i+1,2) ) / 3.d0
coeff(i,3) = ( coeff(i+1,2) - coeff(i,2) ) / 3.d0 / segma(i)
End Do
print*, 'coeff_b:'
print*, coeff(:,1)
print*, 'coeff_c:'
print*, coeff(:,2)
print*, 'coeff_d:'
print*, coeff(:,3)
End subroutine Calcoeff
Subroutine CalInterpolation ()
Implicit none
Character(*), parameter :: filename = 'xx.txt' !// 待插值節點文件
Integer :: info = 0, n, i, j
Real(kind=8) :: dx
Real(kind=8), allocatable :: xx(:), yy(:)
!//---------讀取待插值節點---------
n = 0
Open ( 101, file = filename )
Do
Read ( 101, fmt = *, iostat = info )
If ( info /= 0 ) Exit
n = n + 1
End Do
Allocate( xx(n), yy(n), stat = info )
If ( info == 0 ) Then
Write ( *,'(1x,g0)' ) "Allocate xx, yy array successfully!"
Else
Write ( *,'(1x,g0)' ) "Allocate xx, yy array fail!"
End if
rewind( 101 )
print*, 'n:'
print*, n
Read ( 101,* ) xx
Close ( 101 )
!//---------求取插值---------
outdo:Do i = 1, numLine - 1
indo:Do j = 1, n
If ( xx(j) >= x(i) .and. xx(j) <= x(i+1) ) Then
dx = xx(j) - x(i)
yy(j) = coeff(i,3) * dx !// 使用嵌套乘法求值
yy(j) = ( yy(j) + coeff(i,2) ) * dx
yy(j) = ( yy(j) + coeff(i,1) ) * dx + y(i)
End if
End Do indo
End Do outdo
!//---------輸出插值節點數據---------
Open ( 101, file = 'Interpolation5.dat' )
Do i = 1, n
Write ( 101,'(*(2x,g0))' ) xx(i), yy(i)
End Do
Close ( 101 )
Deallocate( xx, yy )
End subroutine CalInterpolation
Subroutine DeallocateArry ()
Implicit none
Integer :: info = 0
!//---------釋放內存---------
Deallocate( x, y, coeff, a, r, segma, delta, stat = info )
If ( info == 0 ) Then
Write ( *,'(1x,g0)' ) "Deallocate all array successfully!"
Else
Write ( *,'(1x,g0)' ) "Deallocate all array fail!"
End if
End subroutine DeallocateArry
End module CalSpline
Program spline
use CalSpline
Implicit none
Call CalFileLine ()
Call Calcoeff ()
Call CalInterpolation ()
Call DeallocateArry ()
End program spline
