!-------------------------------------- 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_setintuv - computes (u,v) interpolation coefficients
*
#include "model_macros_f.h"
subroutine e_setintuv 1,19
#include "impnone.cdk"
*
*author jean cote - rpn - sept 95
*
*revision
* v0_16 - michel roch - add abort condition for glfipol=.t. with
* v0_16 cubic interpolation of the winds and
* v0_16 associated RHS
* v0_18 - jean cote/andre methot - introduces setinuvl for efficient cubic
* v0_18 lagrange interpolation
* v0_19 - jean cote - remove the option glstslag = false
* v1_00 - jean cote - real*8 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_intuv.cdk
*
*language
* fortran 77
*
*object
* see above ID
*
*arguments
* none
*
*implicits
#include "e_schm.cdk"
#include "e_grids.cdk"
#include "e_geomg.cdk"
#include "e_intuv.cdk"
#include "dcst.cdk"
*
**
real*8 zero, half, one, two, three
parameter( zero = 0.0 )
parameter( half = 0.5 )
parameter( one = 1.0 )
parameter( two = 2.0 )
parameter( three = 3.0 )
*
integer i, j, pnerr
real*8 pdhx(0:*), pdhxu(0:*), pdhy(0:*)
pointer (p_pdhx,pdhx), (p_pdhxu,pdhxu), (p_pdhy,pdhy)
* ---------------------------------------------------------------
*
write(6, 1001 )
call hpalloc(p_pdhx ,(pni+1)*2, pnerr,1)
call hpalloc(p_pdhxu,(pni+1)*2, pnerr,1)
call hpalloc(p_pdhy ,(pnj+1)*2, pnerr,1)
*
if ( .not. e_Schm_stlag ) then
write(6, 1300)
call e_arret( 'e_setintuv' )
endif
*
*
if ( e_Schm_adcub .and.(.not. e_Schm_stlag)) then
write(6, 1200)
call e_arret( 'e_setintuv' )
endif
*
*
*C 0. extend hx, hxu, hy
* ------------------
*
*
do i = 1, pni
pdhx(i) = xdhx(i)
pdhxu(i-1) = xdhxu(i-1)
enddo
pdhx(0) = pdhx(pni)
pdhxu(pni) = pdhxu(0)
do j = 1, pnj
pdhy(j) = xdhy(j)
enddo
pdhy(0) = xdy(1) + half * Dcst_pi_8
pdhy(pnj) = half * Dcst_pi_8 - xdy(pnj)
*
*C 1. compute interpolation polynomials at interpolation points
* ---------------------------------------------------------
*
* x-interpolation from PHI-gdid to U-gdid ( xdx to xdxu )
do i = 1, pni - 1
call e_intpoly( xdc0xxu(i), xdc1xxu(i), xdc2xxu(i),
% xdxu(i) - xdx(i),
% pdhx(i), pdhx(i-1), pdhx(i+1), e_Schm_stlag )
enddo
i = pni
call e_intpoly( xdc0xxu(i), xdc1xxu(i), xdc2xxu(i),
% xdxu(i) - xdx(i),
% pdhx(i), pdhx(i-1), pdhx(1), e_Schm_stlag )
* x-interpolation from U-gdid to PHI-gdid ( xdxu to xdx )
do i = 1, pni - 1
call e_intpoly( xdc0xux(i), xdc1xux(i), xdc2xux(i),
% xdx(i+1) - xdxu(i),
% pdhxu(i), pdhxu(i-1), pdhxu(i+1), e_Schm_stlag )
enddo
i = pni
call e_intpoly( xdc0xux(i), xdc1xux(i), xdc2xux(i),
% two * Dcst_pi_8 + xdx(1) - xdxu(i),
% pdhxu(i), pdhxu(i-1), pdhxu(1), e_Schm_stlag )
* y-interpolation from PHI-gdid to V-gdid ( xdy to xdyv )
do j = 1, pnj-1
call e_intpoly( xdc0yyv(j), xdc1yyv(j), xdc2yyv(j),
% xdyv(j) - xdy(j),
% pdhy(j), pdhy(j-1), pdhy(j+1), e_Schm_stlag )
enddo
* y-interpolation from V-gdid to PHI-gdid ( xdyv to xdy )
j = 0
if ( e_Schm_stlag ) then
xdc0yvy(j) = ( xdy(j+1) + half * Dcst_pi_8 ) / xdhyv(j)
xdc1yvy(j) = zero
xdc2yvy(j) = xdc0yvy(j) * ( xdc0yvy(j) - one ) * xdhyv(j) ** 2
else
call e_intpoly( xdc0yvy(j), xdc1yvy(j), xdc2yvy(j),
% xdy(j+1) + half * Dcst_pi_8,
% xdhyv(j), xdhyv(j), xdhyv(j), e_Schm_stlag )
endif
do j = 1, pnjv - 1
call e_intpoly( xdc0yvy(j), xdc1yvy(j), xdc2yvy(j),
% xdy(j+1) - xdyv(j),
% xdhyv(j), xdhyv(j-1), xdhyv(j+1), e_Schm_stlag )
enddo
j = pnjv
if ( e_Schm_stlag ) then
xdc0yvy(j) = ( xdy(j+1) - xdyv(j) ) / xdhyv(j)
xdc1yvy(j) = xdc0yvy(j) * ( xdc0yvy(j) - one ) * xdhyv(j) ** 2
xdc2yvy(j) = zero
else
call e_intpoly( xdc0yvy(j), xdc1yvy(j), xdc2yvy(j),
% xdy(j+1) - xdyv(j),
% xdhyv(j), xdhyv(j), xdhyv(j), e_Schm_stlag )
endif
*
*
*C 2. compute second derivative/difference operators
* ----------------------------------------------
*
call set_ops8( xdq2x, pdhx(1), two, .true., pni, pni, 1 )
call set_ops8( xdq2u, pdhxu(1), two, .true., pni, pni, 1 )
call set_ops8( xdq2y, pdhy(1), two, .false., pnj, pnj, 1 )
call set_ops8( xdq2v, xdhyv(1), two, .false., pnjv, pnj, 1 )
xdq2y(1,2) = xdq2y(1,2) - one / pdhy(0)
xdq2y(pnj,2) = xdq2y(pnj,2) - one / pdhy(pnj)
xdq2v(1,2) = xdq2v(1,2) - one / xdhyv(0)
xdq2v(pnjv,2) = xdq2v(pnjv,2) - one / xdhyv(pnjv)
if ( e_Schm_stlag ) then
do i = 1, pni
xdqix(i,1) = one/( pdhx(i-1) + pdhx(i) )
xdqiu(i,1) = one/( pdhxu(i-1) + pdhxu(i) )
enddo
do j = 1, pnj
xdqiy(j,1) = one/( pdhy(j-1) + pdhy(j) )
enddo
do j = 1, pnjv
xdqiv(j,1) = one/( xdhyv(j-1) + xdhyv(j) )
enddo
else
call set_ops8 ( xdqix, pdhx(1), two, .true., pni, pni, 2 )
call set_trig21( xdqix(1,1), xdqix(1,2), xdqix(1,3), xdqix(1,4),
% xdqix(1,1), xdqix(1,2), xdqix(1,3),
% 1,1, pni, 1, .true. )
call set_ops8 ( xdqiu, pdhxu(1), two, .true., pni, pni, 2 )
call set_trig21( xdqiu(1,1), xdqiu(1,2), xdqiu(1,3), xdqiu(1,4),
% xdqiu(1,1), xdqiu(1,2), xdqiu(1,3),
% 1,1, pni, 1, .true. )
C THIS CODE NEEDS FURTHER CONSIDERATION DUE TO NEW SET_OPS8
C
C call set_ops8 ( xdqiy, pdhy(1), two, .false., pnj, pnj, 2 )
C xdqiy(1,2) = xdqiy(1,2) + pdhy(0) / three
C xdqiy(pnj,2) = xdqiy(pnj,2) + pdhy(pnj) / three
C call set_trig21( xdqiy(1,1), xdqiy(1,2), xdqiy(1,3), xdqiy(1,4),
C % xdqiy(1,1), xdqiy(1,2), xdqiy(1,3),
C % 1, 1, pnj, 1, .false. )
C call set_ops8 ( xdqiv, xdhyv(1), two, .false., pnjv, pnj, 2 )
C xdqiv(1,2) = xdqiv(1,2) + xdhyv(0) / three
C xdqiv(pnjv,2) = xdqiv(pnjv,2) + xdhyv(pnjv) / three
C call set_trig21( xdqiv(1,1), xdqiv(1,2), xdqiv(1,3), xdqiv(1,4),
C % xdqiv(1,1), xdqiv(1,2), xdqiv(1,3),
C % 1, 1, pnjv, 1, .false. )
endif
*
*
*
*C 3. e_setinuvl for efficient cubic lagrange interpolation
* ---------------------------------------------------
*
if ( e_Schm_stlag ) then
call e_setinuvl
endif
call hpdeallc(p_pdhx, pnerr,1)
call hpdeallc(p_pdhxu, pnerr,1)
call hpdeallc(p_pdhy, pnerr,1)
*
*
1001 format(
%/'COMPUTE (U,V) INTERPOLATION COEFFICIENTS (S/R E_SETINTUV)',
% /'======================================================='/)
1200 format(
%/'CUBIC SPLINES FOR COMPUTATION OF CORIOLIS TERMS OR RHU AND RHV
% ARE NOT ALLOWED: ONLY CUBIC OF LAGRANGE ARE ALLOWED'/)
1300 format(
%/'ONLY CUBIC OF LAGRANGE ARE ALLOWED'/)
*
* ---------------------------------------------------------------
*
return
end