!-------------------------------------- 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 e_int_ix2xu - cubic or linear interpolation from x to xu
*
subroutine e_int_ix2xu( frr, frf, frs, fnk, fnis, fnjs, fnks, fnlat, 1,2
% flcub )
#include "impnone.cdk"
*
logical flcub
integer fnk, fnlat
integer fnis, fnjs, fnks
real frr(fnis,fnjs,fnks), frf(fnis,fnjs,fnks),
% frs(fnis,fnjs)
*
*author jean cote - rpn - sept 95
*
*revision
* v0_18 - cote/methot - introduce efficient cubic lagrange
* v0_18 interpolation
* v1_00 - jean cote - real and real*8 versions simultanously
* v1_00 with CPP
* v1_00 - in-line the cald2x and int_ix2xu* calls
* v1_96 - V. Lee - eliminated cdgeomn.cdk, replaced cdschm.cdk
* v1_96 with schm.cdk
* v1_97 - V. Lee - prefixed comdecks used in GEFNTR with "e_"
* v1_97 - V. Lee - modified to be only a real version
* v1_97 - V. Lee - only the real version is implemented
*
*language
* fortran 77
*
*object
* see above ID
*
*arguments
*______________________________________________________________________
* | |
* NAME | DESCRIPTION |
*--------------------|-------------------------------------------------|
* - output - | |
* frr | field interpolated to xu grid |
* - input - | |
* frf | field on x grid |
* frs | work field |
* fnk | number of levels to process |
* fnis | dimension along x |
* fnjs | dimension along y |
* fnks | dimension along z |
* fnlat | number of latitudes to process |
*----------------------------------------------------------------------
*
*implicits
#include "e_schm.cdk"
#include "e_grids.cdk"
#include "e_intuv.cdk"
#include "e_inuvl.cdk"
*
*notes
* ----------------------------------------
* IMPORTANT: To be used for wind-like quantities ONLY
* ----------------------------------------
*
* Works in place - frr and frf can occupy the same space
*
**
* ----------------------------------------------------------------
*
integer i, j, k, pnerr
real prw
POINTER (P_prw, prw(1))
real*8 prd
real*8 one
parameter( one = 1.0 )
*
call hpalloc(P_prw, fnlat, pnerr, 1)
do 100 k = 1, fnk
*
if ( .not. flcub ) then
*-----------------------------------------------------------------*
* Linear interpolation *
*-----------------------------------------------------------------*
do j = 1, fnlat
prw(j) = frf(1,j,k)
do i = 1, pni-1
frr(i,j,k) = ( one - xdc0xxu(i) ) * frf(i,j,k) +
% xdc0xxu(i) * frf(i+1,j,k)
enddo
enddo
do j = 1, fnlat
frr(pni,j,k) = ( one - xdc0xxu(pni) ) * frf(pni,j,k) +
% xdc0xxu(pni) * prw(j)
enddo
elseif ( .not. e_Schm_stlag ) then
*-----------------------------------------------------------------*
* Cubic spline interpolation *
*-----------------------------------------------------------------*
call optriss6
% ( frs, frf(1,1,k), pni, fnlat, 1, 'X',
% xdq2x(1,1), xdq2x(1,2), xdq2x(1,3),
% .true., fnis, fnjs, 1, 1 )
call opinv6
% ( frs, pni, fnlat, 1, 'X', prd, prd, prd,
% xdqix, xdqix(1,2), xdqix(1,3), xdqix(1,4),
% .false., 'P', fnis, fnjs, 1, 1 )
do j = 1, fnlat
prw(j) = frf(1,j,k)
do i = 1, pni-1
frr(i,j,k) = ( one - xdc0xxu(i) ) * frf(i,j,k) +
% xdc0xxu(i) * frf(i+1,j,k) +
% xdc1xxu(i) * frs(i,j) +
% xdc2xxu(i) * frs(i+1,j)
enddo
enddo
do j = 1, fnlat
frr(pni,j,k) = ( one - xdc0xxu(pni) ) * frf(pni,j,k) +
% xdc0xxu(pni) * prw(j) +
% xdc1xxu(pni) * frs(pni,j) +
% xdc2xxu(pni) * frs(1,j)
enddo
elseif ( loc(frr) .eq. loc(frf) ) then
*-----------------------------------------------------------------*
* Efficient Lagrange cubic interpolation ( in place ) *
*-----------------------------------------------------------------*
do i = 1, fnis * fnjs
frs(i,1) = frf(i,1,k)
enddo
i = 1
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frs(pni,j)
% + xdwxxu3(i,2) * frs(i ,j)
% + xdwxxu3(i,3) * frs(i+1,j)
% + xdwxxu3(i,4) * frs(i+2,j)
enddo
do i= 2, pni - 2
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frs(i-1,j)
% + xdwxxu3(i,2) * frs(i ,j)
% + xdwxxu3(i,3) * frs(i+1,j)
% + xdwxxu3(i,4) * frs(i+2,j)
enddo
enddo
i = pni - 1
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frs(i-1,j)
% + xdwxxu3(i,2) * frs(i ,j)
% + xdwxxu3(i,3) * frs(i+1,j)
% + xdwxxu3(i,4) * frs(1 ,j)
enddo
i = pni
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frs(i-1,j)
% + xdwxxu3(i,2) * frs(i ,j)
% + xdwxxu3(i,3) * frs(1 ,j)
% + xdwxxu3(i,4) * frs(2 ,j)
enddo
else
*-----------------------------------------------------------------*
* Efficient Lagrange cubic interpolation ( not in place ) *
*-----------------------------------------------------------------*
i = 1
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frf(pni,j,k)
% + xdwxxu3(i,2) * frf(i ,j,k)
% + xdwxxu3(i,3) * frf(i+1,j,k)
% + xdwxxu3(i,4) * frf(i+2,j,k)
enddo
do i= 2, pni - 2
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frf(i-1,j,k)
% + xdwxxu3(i,2) * frf(i ,j,k)
% + xdwxxu3(i,3) * frf(i+1,j,k)
% + xdwxxu3(i,4) * frf(i+2,j,k)
enddo
enddo
i = pni - 1
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frf(i-1,j,k)
% + xdwxxu3(i,2) * frf(i ,j,k)
% + xdwxxu3(i,3) * frf(i+1,j,k)
% + xdwxxu3(i,4) * frf(1 ,j,k)
enddo
i = pni
do j = 1, fnlat
frr(i,j,k) = xdwxxu3(i,1) * frf(i-1,j,k)
% + xdwxxu3(i,2) * frf(i ,j,k)
% + xdwxxu3(i,3) * frf(1 ,j,k)
% + xdwxxu3(i,4) * frf(2 ,j,k)
enddo
endif
*
100 continue
*
call hpdeallc(P_prw, pnerr, 1)
return
end