!-------------------------------------- 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 adw_tricub_lag3d - Tri-cubic interpolation: Lagrange 3d
*
#include "model_macros_f.h"
*
subroutine adw_tricub_lag3d ( F_out, F_in, F_x, F_y, F_z, 3
% F_num, F_mono_L, i0, in, j0, jn, kn )
*
implicit none
*
logical F_mono_L
*
integer F_num, i0, in, j0, jn, kn
*
real F_in(*)
*
real F_out (F_num), F_x(F_num), F_y(F_num), F_z(F_num)
*
*authors
* Gravel & Valin & Tanguay
*
* (Based on adw_tricub v_3.1.1)
*
*revision
* v3_20 - Gravel & Valin & Tanguay - initial version
* v3_21 - Desgagne M. - Revision Openmp
*
*object
* see id section
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* F_out | result of interpolation | o |
* F_in | field to interpolate | i |
* | | |
* F_x | interpolation target X coordinate | i |
* F_y | interpolation target Y coordinate | i |
* F_z | interpolation target Z coordinate | i |
* | | |
* F_num | number of points to interpolate | i |
* | | |
* F_mono_L | switch: .true. : monotonic interpolation | i |
*______________|_________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "adw.cdk"
* **********************************************************************
integer n,nijag,i,j,k,nij,iimax,jjmax,kkmax,ii,jj,kk
logical zcubic_L
*
real prmin, prmax
*
integer o1, o2, o3, o4
real*8 a1, a2, a3, a4
real*8 b1, b2, b3, b4
real*8 c1, c2, c3, c4
real*8 d1, d2, d3, d4
real*8 p1, p2, p3, p4
*
real *8 triprd,za,zb,zc,zd,rri,rrj,rrk,ra,rb,rc,rd
triprd(za,zb,zc,zd)=(za-zb)*(za-zc)*(za-zd)
*
* ----------------------------------------------------
*
nij = l_ni*l_nj
nijag = Adw_nit * Adw_njt
*
iimax = G_ni+2*Adw_halox-2
jjmax = G_nj+Adw_haloy
kkmax = l_nk-1
*
if(F_mono_L) then
*
!$omp do
do 100 k=1,kn
do 90 j=j0,jn
do 80 i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
rri= F_x(n)
ii = ( rri - Adw_x00_8 ) * Adw_ovdx_8
ii = Adw_lcx( ii+1 ) + 1
if ( rri .lt. Adw_bsx_8(ii) ) ii = ii - 1
ii = max(2,min(ii,iimax))
*
rrj= F_y(n)
jj = ( rrj - Adw_y00_8 ) * Adw_ovdy_8
jj = Adw_lcy( jj+1 ) + 1
if ( rrj .lt. Adw_bsy_8(jj) ) jj = jj - 1
jj = max(Adw_haloy,min(jj,jjmax))
*
rrk= F_z(n)
kk = ( rrk - Adw_z00_8 ) * Adw_ovdz_8
kk = Adw_lcz( kk+1 )
if ( rrk .lt. Adw_bsz_8(kk) ) kk = kk - 1
kk = min(kkmax-1,max(0,kk))
*
zcubic_L = (kk.gt.0) .and. (kk.lt.kkmax-1)
*
* *********************************************************************
* x interpolation
* *********************************************************************
ra = Adw_bsx_8(ii-1)
rb = Adw_bsx_8(ii )
rc = Adw_bsx_8(ii+1)
rd = Adw_bsx_8(ii+2)
p1 = triprd(rri,rb,rc,rd)*Adw_xabcd_8(ii)
p2 = triprd(rri,ra,rc,rd)*Adw_xbacd_8(ii)
p3 = triprd(rri,ra,rb,rd)*Adw_xcabd_8(ii)
p4 = triprd(rri,ra,rb,rc)*Adw_xdabc_8(ii)
*
o2 = (kk-1)*nijag + (jj-Adw_int_j_off-1)*Adw_nit + (ii-Adw_int_i_off)
o1 = o2-Adw_nit
o3 = o2+Adw_nit
o4 = o3+Adw_nit
*
if(zcubic_L) then
a1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
a2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
a3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
a4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
endif
*
o1 = o1 + nijag
o2 = o2 + nijag
o3 = o3 + nijag
o4 = o4 + nijag
*
prmax = max(F_in(o2),F_in(o2+1),F_in(o3),F_in(o3+1))
prmin = min(F_in(o2),F_in(o2+1),F_in(o3),F_in(o3+1))
b1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
b2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
b3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
b4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
*
o1 = o1 + nijag
o2 = o2 + nijag
o3 = o3 + nijag
o4 = o4 + nijag
*
prmax = max(prmax,F_in(o2),F_in(o2+1),F_in(o3),F_in(o3+1))
prmin = min(prmin,F_in(o2),F_in(o2+1),F_in(o3),F_in(o3+1))
c1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
c2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
c3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
c4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
*
o1 = o1 + nijag
o2 = o2 + nijag
o3 = o3 + nijag
o4 = o4 + nijag
*
if(zcubic_L) then
d1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
d2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
d3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
d4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
endif
* *********************************************************************
* y interpolation
* *********************************************************************
ra = Adw_bsy_8(jj-1)
rb = Adw_bsy_8(jj )
rc = Adw_bsy_8(jj+1)
rd = Adw_bsy_8(jj+2)
p1 = triprd(rrj,rb,rc,rd)*Adw_yabcd_8(jj)
p2 = triprd(rrj,ra,rc,rd)*Adw_ybacd_8(jj)
p3 = triprd(rrj,ra,rb,rd)*Adw_ycabd_8(jj)
p4 = triprd(rrj,ra,rb,rc)*Adw_ydabc_8(jj)
*
if(zcubic_L) a1 = p1 * a1 + p2 * a2 + p3 * a3 + p4 * a4
b1 = p1 * b1 + p2 * b2 + p3 * b3 + p4 * b4
c1 = p1 * c1 + p2 * c2 + p3 * c3 + p4 * c4
if(zcubic_L) d1 = p1 * d1 + p2 * d2 + p3 * d3 + p4 * d4
* *********************************************************************
* z interpolation
* *********************************************************************
if(zcubic_L) then
ra = Adw_bsz_8(kk-1)
rb = Adw_bsz_8(kk )
rc = Adw_bsz_8(kk+1)
rd = Adw_bsz_8(kk+2)
p1 = triprd(rrk,rb,rc,rd)*Adw_zabcd_8(kk+1)
p2 = triprd(rrk,ra,rc,rd)*Adw_zbacd_8(kk+1)
p3 = triprd(rrk,ra,rb,rd)*Adw_zcabd_8(kk+1)
p4 = triprd(rrk,ra,rb,rc)*Adw_zdabc_8(kk+1)
*
F_out(n) = p1 * a1 + p2 * b1 + p3 * c1 + p4 * d1
*
else
p3 = (rrk-Adw_bsz_8(kk))*Adw_zbc_8(kk+1)
p2 = 1. - p3
*
F_out(n) = p2 * b1 + p3 * c1
endif
*
F_out(n) = max ( prmin , min(prmax,F_out(n)) )
*
80 continue
90 continue
100 continue
!$omp enddo
*
else
*
!$omp do
*
do 101 k=1,kn
do 91 j=j0,jn
do 81 i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
rri= F_x(n)
ii = ( rri - Adw_x00_8 ) * Adw_ovdx_8
ii = Adw_lcx( ii+1 ) + 1
if ( rri .lt. Adw_bsx_8(ii) ) ii = ii - 1
ii = max(2,min(ii,iimax))
*
rrj= F_y(n)
jj = ( rrj - Adw_y00_8 ) * Adw_ovdy_8
jj = Adw_lcy( jj+1 ) + 1
if ( rrj .lt. Adw_bsy_8(jj) ) jj = jj - 1
jj = max(Adw_haloy,min(jj,jjmax))
*
rrk= F_z(n)
kk = ( rrk - Adw_z00_8 ) * Adw_ovdz_8
kk = Adw_lcz( kk+1 )
if ( rrk .lt. Adw_bsz_8(kk) ) kk = kk - 1
kk = min(kkmax-1,max(0,kk))
*
zcubic_L = (kk.gt.0) .and. (kk.lt.kkmax-1)
*
* *********************************************************************
* x interpolation
* *********************************************************************
ra = Adw_bsx_8(ii-1)
rb = Adw_bsx_8(ii )
rc = Adw_bsx_8(ii+1)
rd = Adw_bsx_8(ii+2)
p1 = triprd(rri,rb,rc,rd)*Adw_xabcd_8(ii)
p2 = triprd(rri,ra,rc,rd)*Adw_xbacd_8(ii)
p3 = triprd(rri,ra,rb,rd)*Adw_xcabd_8(ii)
p4 = triprd(rri,ra,rb,rc)*Adw_xdabc_8(ii)
*
o2 = (kk-1)*nijag + (jj-Adw_int_j_off-1)*Adw_nit + (ii-Adw_int_i_off)
o1 = o2-Adw_nit
o3 = o2+Adw_nit
o4 = o3+Adw_nit
*
if(zcubic_L) then
a1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
a2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
a3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
a4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
endif
*
o1 = o1 + nijag
o2 = o2 + nijag
o3 = o3 + nijag
o4 = o4 + nijag
*
b1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
b2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
b3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
b4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
*
o1 = o1 + nijag
o2 = o2 + nijag
o3 = o3 + nijag
o4 = o4 + nijag
*
c1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
c2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
c3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
c4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
*
o1 = o1 + nijag
o2 = o2 + nijag
o3 = o3 + nijag
o4 = o4 + nijag
*
if(zcubic_L) then
d1 = p1 * F_in (o1-1) + p2 * F_in (o1) + p3 * F_in (o1+1) + p4 * F_in (o1+2)
d2 = p1 * F_in (o2-1) + p2 * F_in (o2) + p3 * F_in (o2+1) + p4 * F_in (o2+2)
d3 = p1 * F_in (o3-1) + p2 * F_in (o3) + p3 * F_in (o3+1) + p4 * F_in (o3+2)
d4 = p1 * F_in (o4-1) + p2 * F_in (o4) + p3 * F_in (o4+1) + p4 * F_in (o4+2)
endif
* *********************************************************************
* y interpolation
* *********************************************************************
ra = Adw_bsy_8(jj-1)
rb = Adw_bsy_8(jj )
rc = Adw_bsy_8(jj+1)
rd = Adw_bsy_8(jj+2)
p1 = triprd(rrj,rb,rc,rd)*Adw_yabcd_8(jj)
p2 = triprd(rrj,ra,rc,rd)*Adw_ybacd_8(jj)
p3 = triprd(rrj,ra,rb,rd)*Adw_ycabd_8(jj)
p4 = triprd(rrj,ra,rb,rc)*Adw_ydabc_8(jj)
*
if(zcubic_L) a1 = p1 * a1 + p2 * a2 + p3 * a3 + p4 * a4
b1 = p1 * b1 + p2 * b2 + p3 * b3 + p4 * b4
c1 = p1 * c1 + p2 * c2 + p3 * c3 + p4 * c4
if(zcubic_L) d1 = p1 * d1 + p2 * d2 + p3 * d3 + p4 * d4
* *********************************************************************
* z interpolation
* *********************************************************************
if(zcubic_L) then
ra = Adw_bsz_8(kk-1)
rb = Adw_bsz_8(kk )
rc = Adw_bsz_8(kk+1)
rd = Adw_bsz_8(kk+2)
p1 = triprd(rrk,rb,rc,rd)*Adw_zabcd_8(kk+1)
p2 = triprd(rrk,ra,rc,rd)*Adw_zbacd_8(kk+1)
p3 = triprd(rrk,ra,rb,rd)*Adw_zcabd_8(kk+1)
p4 = triprd(rrk,ra,rb,rc)*Adw_zdabc_8(kk+1)
*
F_out(n) = p1 * a1 + p2 * b1 + p3 * c1 + p4 * d1
*
else
p3 = (rrk-Adw_bsz_8(kk))*Adw_zbc_8(kk+1)
p2 = 1. - p3
*
F_out(n) = p2 * b1 + p3 * c1
endif
*
81 continue
91 continue
101 continue
!$omp enddo
*
endif
*
return
end