!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r v4d_irgdint_3_w - Cubic interpolation with wrap around
* based on EZ_IRGDINT_3_W (Y.Chartier EZSCINT 2001)
*
subroutine v4d_irgdint_3_w (zo,px,py,npts,ax,ay,cx,cy,zi,ni,j1,j2,nk) 7
*
#include "impnone.cdk"
*
integer npts,ni,j1,j2,nk
real zo(nk,npts),zi(ni,j1:j2,nk),
% px(npts),py(npts),ax(ni),ay(j1:j2),cx(ni,6),cy(j1:j2,6)
*
*author Tanguay M.
*
*revision
* v3_00 - Tanguay M. - initial MPI version
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* zo O Interpolated field at positions px,py
* px I Position x in INPUT grid
* py I Position y in INPUT grid
* npts I Number of positions in zo
* zi I Field on INPUT grid
* ax I X axe of INPUT grid
* ay I Y axe of INPUT grid
* cx I AX difference on INPUT grid
* cy I AY difference on INPUT grid
* ni I Dimension x in INPUT grid
* j1-j2 I Dimension y in INPUT grid
* nk I Dimension z in INPUT grid
*----------------------------------------------------------------
*
integer i,j,n,k,iplus1,iplus2,imoins1,
% tabplus1(ni),tabplus2(ni),tabmoins1(ni)
real*8 a11_8,a12_8,a13_8,a14_8,a21_8,a22_8,a23_8,a24_8,
% a31_8,a32_8,a33_8,a34_8,a41_8,a42_8,a43_8,a44_8,
% b11_8,b12_8,b13_8,b14_8
*
real*8 x1_8,x2_8,x3_8,x4_8,y1_8,y2_8,y3_8,y4_8,
% a1_8,a2_8,a3_8,a4_8,b1_8,b2_8,b3_8,b4_8,
% c1_8,c2_8,c3_8,c4_8,c5_8,c6_8,
% x_8,y_8
*
real ax_ext(0:ni+2)
*
* Definition of in-line functions
* -------------------------------
real fa,fa2,fa3,fa4
real*8 z1_8,z2_8,z3_8,z4_8
*
fa (a1_8,a2_8,a3_8,a4_8,x_8,x1_8,x2_8,x3_8)
% =a1_8+(x_8-x1_8)*(a2_8+(x_8-x2_8)*(a3_8+a4_8*(x_8-x3_8)))
*
fa2(c1_8,a1_8,a2_8)
% =c1_8*(a2_8-a1_8)
*
fa3(c1_8,c2_8,c3_8,a1_8,a2_8,a3_8)
% =c2_8*(c3_8*(a3_8-a2_8)-c1_8*(a2_8-a1_8))
*
fa4(c1_8,c2_8,c3_8,c4_8,c5_8,c6_8,a1_8,a2_8,a3_8,a4_8)
% =c4_8*(c5_8*(c6_8*(a4_8-a3_8)
% -c3_8*(a3_8-a2_8))-c2_8*(c3_8*(a3_8-a2_8)-c1_8*(a2_8-a1_8)))
*
* Define tables to restaure vectorization
* ---------------------------------------
do i=1,ni
ax_ext(i) = ax(i)
enddo
ax_ext(0 ) = ax(ni)-360.0
ax_ext(ni+1) = ax( 1)+360.0
ax_ext(ni+2) = ax( 2)+360.0
*
do i=1,ni-1
tabplus1(i) = i+1
enddo
tabplus1(ni) = 1
*
do i=1,ni-2
tabplus2(i) = i+2
enddo
tabplus2(ni-1) = 1
tabplus2(ni ) = 2
*
do i=2,ni
tabmoins1(i) = i-1
enddo
tabmoins1(1) = ni
*
* Interpolation
* -------------
do n=1,npts
do k=1,nk
*
i = min(ni, max(1, max(0,ifix(px(n)))))
j = min(j2-2,max(j1+1, ifix(py(n))))
*
imoins1 = tabmoins1(i)
iplus1 = tabplus1 (i)
iplus2 = tabplus2 (i)
*
x1_8=ax_ext(i-1)
x2_8=ax_ext(i )
x3_8=ax_ext(i+1)
x4_8=ax_ext(i+2)
*
y1_8=ay(j-1)
y2_8=ay(j)
y3_8=ay(j+1)
y4_8=ay(j+2)
*
x_8 = x2_8 + (x3_8-x2_8)*(px(n)-i)
y_8 = ay(j) + (ay(j+1)-ay(j))*(py(n)-j)
*
* interpolation row 1
* -------------------
z1_8=zi(imoins1,j-1,k)
z2_8=zi(i, j-1,k)
z3_8=zi(iplus1, j-1,k)
z4_8=zi(iplus2, j-1,k)
*
a11_8 = z1_8
a12_8 = fa2(dble(cx(i,1)),z1_8,z2_8)
a13_8 = fa3(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),z1_8,z2_8,z3_8)
a14_8 = fa4(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),
% dble(cx(i,4)),dble(cx(i,5)),dble(cx(i,6)),z1_8,z2_8,z3_8,z4_8)
b1_8 = fa(a11_8,a12_8,a13_8,a14_8,x_8,x1_8,x2_8,x3_8)
*
* interpolation row 2
* -------------------
z1_8=zi(imoins1,j,k)
z2_8=zi(i, j,k)
z3_8=zi(iplus1, j,k)
z4_8=zi(iplus2, j,k)
*
a21_8 = z1_8
a22_8 = fa2(dble(cx(i,1)),z1_8,z2_8)
a23_8 = fa3(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),z1_8,z2_8,z3_8)
a24_8 = fa4(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),
% dble(cx(i,4)),dble(cx(i,5)),dble(cx(i,6)),z1_8,z2_8,z3_8,z4_8)
b2_8 = fa(a21_8,a22_8,a23_8,a24_8,x_8,x1_8,x2_8,x3_8)
*
* interpolation row 3
* -------------------
z1_8=zi(imoins1,j+1,k)
z2_8=zi(i ,j+1,k)
z3_8=zi(iplus1, j+1,k)
z4_8=zi(iplus2, j+1,k)
*
a31_8 = z1_8
a32_8 = fa2(dble(cx(i,1)),z1_8,z2_8)
a33_8 = fa3(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),z1_8,z2_8,z3_8)
a34_8 = fa4(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),dble(cx(i,4)),
% dble(cx(i,5)),dble(cx(i,6)),z1_8,z2_8,z3_8,z4_8)
b3_8 = fa(a31_8,a32_8,a33_8,a34_8,x_8,x1_8,x2_8,x3_8)
*
* interpolation row 4
* -------------------
z1_8=zi(imoins1,j+2,k)
z2_8=zi(i, j+2,k)
z3_8=zi(iplus1, j+2,k)
z4_8=zi(iplus2, j+2,k)
*
a41_8 = z1_8
a42_8 = fa2(dble(cx(i,1)),z1_8,z2_8)
a43_8 = fa3(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),z1_8,z2_8,z3_8)
a44_8 = fa4(dble(cx(i,1)),dble(cx(i,2)),dble(cx(i,3)),dble(cx(i,4)),
% dble(cx(i,5)),dble(cx(i,6)),z1_8,z2_8,z3_8,z4_8)
b4_8 = fa(a41_8,a42_8,a43_8,a44_8,x_8,x1_8,x2_8,x3_8)
*
* interpolation column
* --------------------
b11_8 = b1_8
b12_8 = fa2(dble(cy(j,1)),b1_8,b2_8)
b13_8 = fa3(dble(cy(j,1)),dble(cy(j,2)),dble(cy(j,3)),b1_8,b2_8,b3_8)
b14_8 = fa4(dble(cy(j,1)),dble(cy(j,2)),dble(cy(j,3)),
% dble(cy(j,4)),dble(cy(j,5)),dble(cy(j,6)),b1_8,b2_8,b3_8,b4_8)
zo(k,n) = fa(b11_8,b12_8,b13_8,b14_8,y_8,y1_8,y2_8,y3_8)
*
end do
end do
*
return
end