!-------------------------------------- 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_setinuvl - setup coefficients for cubic lagrange interpolation of
* wind-like quantities from one grid to another
*
#include "model_macros_f.h"
*
subroutine e_setinuvl 1
#include "impnone.cdk"
*
*author jean cote/andre methot - rpn/cmc - sept 96
*
*revision
* v0_18 - cote/methot - initial version
* v1_00 - jean cote - real*8 version
* v1_94 - joseph-pierre toviessi - adapt v1_03 version to mpi version
* v1_96 - V. Lee - comdeck cleanup and revision for gempp
* v1_97 - V. Lee - added prefix "e_" to GEFNTR comdecks,
* v1_97 eliminated mvr8tor, modified e_inuvl.cdk
*
*language
* fortran 77
*
*object
* see above ID.
*
*arguments
* none
*
*implicits
#include "dcst.cdk"
#include "e_grids.cdk"
#include "e_geomg.cdk"
#include "e_inuvl.cdk"
*
*
**
real*8 two
parameter( two = 2.0 )
*
integer i, j
*
real*8 lag2, lag3, pdx, pdx1, pdx2, pdx3, pdx4
lag2( pdx, pdx1, pdx2, pdx3 ) =
% ( ( pdx - pdx2 ) * ( pdx - pdx3 ) )/
% ( ( pdx1 - pdx2 ) * ( pdx1 - pdx3 ) )
lag3( pdx, pdx1, pdx2, pdx3, pdx4 ) =
% ( ( pdx - pdx2 ) * ( pdx - pdx3 ) * ( pdx - pdx4 ) )/
% ( ( pdx1 - pdx2 ) * ( pdx1 - pdx3 ) * ( pdx1 - pdx4 ) )
*
* ---------------------------------------------------------------
*
write(6, 1001 )
*
* prepares interpolation weights for x -> xu
*
pdx1 = xdx(pni) - two * Dcst_pi_8
pdx2 = xdx(1)
pdx3 = xdx(2)
pdx4 = xdx(3)
do i=1,pni
xdwxxu3(i,1) = lag3( xdxu(i), pdx1, pdx2, pdx3, pdx4 )
xdwxxu3(i,2) = lag3( xdxu(i), pdx2, pdx1, pdx3, pdx4 )
xdwxxu3(i,3) = lag3( xdxu(i), pdx3, pdx1, pdx2, pdx4 )
xdwxxu3(i,4) = lag3( xdxu(i), pdx4, pdx1, pdx2, pdx3 )
pdx1 = pdx2
pdx2 = pdx3
pdx3 = pdx4
if ( i+1 .le. pni - 2 ) then
pdx4 = xdx(i+1+2)
elseif ( i+1 .eq. pni - 1 ) then
pdx4 = xdx(1) + two * Dcst_pi_8
elseif ( i+1 .eq. pni ) then
pdx4 = xdx(2) + two * Dcst_pi_8
endif
enddo
*
* prepares interpolation weights for xu -> x
*
pdx4 = xdxu(1) + two * Dcst_pi_8
pdx3 = xdxu(pni)
pdx2 = xdxu(pni-1)
pdx1 = xdxu(pni-2)
do i=pni,1,-1
xdwxux3(i,1) = lag3( xdx(i), pdx1, pdx2, pdx3, pdx4 )
xdwxux3(i,2) = lag3( xdx(i), pdx2, pdx1, pdx3, pdx4 )
xdwxux3(i,3) = lag3( xdx(i), pdx3, pdx1, pdx2, pdx4 )
xdwxux3(i,4) = lag3( xdx(i), pdx4, pdx1, pdx2, pdx3 )
pdx4 = pdx3
pdx3 = pdx2
pdx2 = pdx1
if ( i-1 .ge. 3 ) then
pdx1 = xdxu(i-1-2)
elseif ( i-1 .eq. 2 ) then
pdx1 = xdxu(pni) - two * Dcst_pi_8
elseif ( i-1 .eq. 1 ) then
pdx1 = xdxu(pni-1) - two * Dcst_pi_8
endif
enddo
*
* prepares interpolation weights for y -> yv
*
pdx1 = - Dcst_pi_8/two
pdx2 = xdy(1)
pdx3 = xdy(2)
pdx4 = xdy(3)
do j=1,pnj-1
xdwyyv3(j,1) = lag3( xdyv(j), pdx1, pdx2, pdx3, pdx4 )
xdwyyv3(j,2) = lag3( xdyv(j), pdx2, pdx1, pdx3, pdx4 )
xdwyyv3(j,3) = lag3( xdyv(j), pdx3, pdx1, pdx2, pdx4 )
xdwyyv3(j,4) = lag3( xdyv(j), pdx4, pdx1, pdx2, pdx3 )
pdx1 = pdx2
pdx2 = pdx3
pdx3 = pdx4
if ( j+1 .le. pnj - 2 ) then
pdx4 = xdy(j+1+2)
elseif ( j+1 .eq. pnj - 1 ) then
pdx4 = Dcst_pi_8/two
endif
enddo
*
* prepares interpolation weights for yv -> y
*
pdx4 = Dcst_pi_8/two
pdx3 = xdyv(pnj-1)
pdx2 = xdyv(pnj-2)
pdx1 = xdyv(pnj-3)
j = pnj
xdwyvy3(j,1) = lag2( xdy(j), pdx2, pdx3, pdx4 )
xdwyvy3(j,2) = lag2( xdy(j), pdx3, pdx2, pdx4 )
xdwyvy3(j,3) = lag2( xdy(j), pdx4, pdx2, pdx3 )
do j=pnj-1,2,-1
xdwyvy3(j,1) = lag3( xdy(j), pdx1, pdx2, pdx3, pdx4 )
xdwyvy3(j,2) = lag3( xdy(j), pdx2, pdx1, pdx3, pdx4 )
xdwyvy3(j,3) = lag3( xdy(j), pdx3, pdx1, pdx2, pdx4 )
xdwyvy3(j,4) = lag3( xdy(j), pdx4, pdx1, pdx2, pdx3 )
pdx4 = pdx3
pdx3 = pdx2
pdx2 = pdx1
if ( j-1 .ge. 3 ) then
pdx1 = xdyv(j-1-2)
elseif ( j-1 .eq. 2 ) then
pdx1 = - Dcst_pi_8/two
endif
enddo
j = 1
xdwyvy3(j,2) = lag2( xdy(j), pdx2, pdx3, pdx4 )
xdwyvy3(j,3) = lag2( xdy(j), pdx3, pdx2, pdx4 )
xdwyvy3(j,4) = lag2( xdy(j), pdx4, pdx2, pdx3 )
*
return
*
1001 format(
%/,'COMPUTE (U,V) CUBIC LAGRANGE INTERP. COEFF. (S/R E_SETINUVL)',
% /,'==========================================================',
%/)
end