Subroutine : |
|
x(:) : | real, intent(in)
|
y(:) : | real, intent(in)
|
fg(size(x),size(y)) : | real, intent(in)
|
obs_posix(:) : | real, intent(in)
|
obs_posiy(:) : | real, intent(in)
|
obs(size(obs_posix),size(obs_posiy)) : | real, intent(in)
|
method : | character(1), intent(in)
: | 影響球の形 ‘B’ : Barnes (1964) によるガウシアン球
‘C’ : Cressman (1959) による有限球
|
|
inter_val(size(x),size(y)) : | real, intent(inout)
|
rad : | real, intent(in), optional
: | 影響球の半径[x 系での値] デフォルトは各格子点からの最近の観測点を 計算し,
その最遠距離を設定.
|
|
hx(size(x)) : | real, intent(in), optional
: | x 系におけるスケール因子. デフォルトはデカルト座標系として計算.
|
|
hy(size(y)) : | real, intent(in), optional
: | y 系におけるスケール因子. デフォルトはデカルト座標系として計算.
|
|
hobsx(size(obs_posix)) : | real, intent(in), optional
: | 観測点で定義された x 系におけるスケール因子.
デフォルトはデカルト座標系として計算.
|
|
hobsy(size(obs_posiy)) : | real, intent(in), optional
: | 観測点で定義された y 系におけるスケール因子.
デフォルトはデカルト座標系として計算.
|
|
lambda : | real, intent(in), optional
: | 観測誤差標準偏差 / 背景誤差標準偏差 デフォルトではゼロ.
real, intent(in), optional :: undef ! 観測の欠損値[第一推定値には欠損がない]
|
|
, undef ) 2 次元データについて, 逐次修正法による内挿を行う. ここで,
第一推定値から観測点への内挿は線形内挿を行うものとする.
第一推定値をゼロとすれば, 純粋な逐次内挿が行われる. つまり,
観測値のみから推定した内挿が行える.
subroutine successive_modif_2d( x, y, fg, obs_posix, obs_posiy, obs, method, inter_val, rad, hx, hy, hobsx, hobsy, lambda )!, undef )
! 2 次元データについて, 逐次修正法による内挿を行う.
! ここで, 第一推定値から観測点への内挿は線形内挿を行うものとする.
! 第一推定値をゼロとすれば, 純粋な逐次内挿が行われる.
! つまり, 観測値のみから推定した内挿が行える.
use statistics
use max_min
!作成途中
implicit none
real, intent(in) :: x(:) ! 内挿点での第 1 座標値[直交座標系]
real, intent(in) :: y(:) ! 内挿点での第 2 座標値[直交座標系]
real, intent(in) :: fg(size(x),size(y)) ! 内挿点での第一推定値
real, intent(in) :: obs_posix(:) ! 観測点の座標値[x 系での値]
real, intent(in) :: obs_posiy(:) ! 観測点の座標値[y 系での値]
real, intent(in) :: obs(size(obs_posix),size(obs_posiy)) ! 観測点での観測値
character(1), intent(in) :: method ! 影響球の形
! 'B' : Barnes (1964) によるガウシアン球
! 'C' : Cressman (1959) による有限球
real, intent(inout) :: inter_val(size(x),size(y)) ! 内挿された値
real, intent(in), optional :: rad ! 影響球の半径[x 系での値]
! デフォルトは各格子点からの最近の観測点を
! 計算し, その最遠距離を設定.
real, intent(in), optional :: hx(size(x)) ! x 系におけるスケール因子.
! デフォルトはデカルト座標系として計算.
real, intent(in), optional :: hy(size(y)) ! y 系におけるスケール因子.
! デフォルトはデカルト座標系として計算.
real, intent(in), optional :: hobsx(size(obs_posix)) ! 観測点で定義された x 系におけるスケール因子.
! デフォルトはデカルト座標系として計算.
real, intent(in), optional :: hobsy(size(obs_posiy)) ! 観測点で定義された y 系におけるスケール因子.
! デフォルトはデカルト座標系として計算.
real, intent(in), optional :: lambda ! 観測誤差標準偏差 / 背景誤差標準偏差
! デフォルトではゼロ.
! real, intent(in), optional :: undef ! 観測の欠損値[第一推定値には欠損がない]
integer :: nx, i, j, k, nob
real :: lam
real :: wei(size(x),size(obs_posi)), interp(size(obs_posi))
real :: radius(size(x),size(obs_posi)), geo_fg(size(x))
real :: geo_obs(size(obs_posi))
real :: sphe_rad
!-- undef 対応のため, undef が入っている観測点は
nx=size(x)
nob=size(obs_posi)
if(present(lambda))then
lam=lambda
else
lam=0.0
end if
!-- スケール因子が入力されている場合, 幾何的直交座標系に落とす.
if(present(hx).and.present(hobs))then
do i=1,nx
geo_fg(i)=hx(i)*x(i)
end do
do k=1,nob
geo_obs(i)=hobs(i)*obs_posi(i)
end do
else
if(present(hx).or.present(hobs))then ! どちらかしかない場合, エラーとなる.
write(*,*) "#### ERROR ####"
write(*,*) "hx 'and' hobs must be set. STOP"
stop
else
do i=1,nx
geo_fg(i)=x(i)
end do
do k=1,nob
geo_obs(i)=obs_posi(i)
end do
end if
end if
!-- rad が指定されていない場合の, 半径の計算
!-- 各格子点での最近接観測点までの距離で, 最遠となる値.
if(present(rad))then
sphe_rad=rad
else
do i=1,nx
call nearest_search_1d( geo_obs, geo_fg(i), obs_i )
fg2obs(i)=abs(geo_obs(obs_i)-geo_fg(i))
end do
call max_val_1d( fg2obs, obs_i, sphe_rad)
end if
!-- 第一推定値を用いて, 観測点すべてに第一推定値の線形内挿を行う.
do k=1,nob
call interpo_search_1d( x, obs_posi(k), fg_interp )
call interpolation_1d( x(fg_interp:fg_interp+1), fg(fg_interp:fg_interp+1), obs_posi(k), interp(k) )
end do
!-- 各第一推定値格子点から, 全観測点までの直線距離を計算する.
do k=1,nob
do i=1,nx
radius(i,k)=sqrt((geo_fg(i)-geo_obs(k))*(geo_fg(i)-geo_obs(k)))
end do
end do
!-- 重み関数の計算
select case(method)
case('B') ! Barnes 法
do k=1,nob
do i=1,nx
wei(i,k)=exp(-(radius(i,k))/(sphe_rad))
end do
end do
case('C') ! Cressman 法
do k=1,nob
do i=1,nx
if(radius(i,j)<rad)then
wei(i,k)=(sphe_rad**2-radius(i,k)**2)/(sphe_rad**2+radius(i,k)**2)
else
wei(i,k)=0.0
end if
end do
end do
case default
write(*,*) "#### ERROR ####"
write(*,*) "method is not specified or, wrong. STOP"
stop
end select
!-- 修正項の計算
do i=1,nx
summ(i)=0.0
summ_wei(i)=0.0
do k=1,nob
if(wei(i,j)/=0.0)then
summ(i)=summ(i)+wei(i,k)*(obs(k)-intep(k))
summ_wei(i)=summ_wei(i)+wei(i,k)
end do
end do
end do
do i=1,nx
inter_val(i)=fg(i)+(summ(i))/(summ_wei(i)+lam**2)
end do
end subroutine successive_modif_1d