!-------------------------------------- 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 vte_intvertx cubic vertical interpolation from eta/sigma to hybrid
*
subroutine vte_intvertx (F_dch,F_sch,F_srclev,F_dstlev,n,nks,nkd,F_var) 1
#include "impnone.cdk"
*
integer n, nkd, nks
real F_dch(n,nkd), F_sch(n,nks), F_srclev(n,nks),F_dstlev(n,nks)
character*2 F_var
*
*author - Methot/Laroche - April 97 - v1_01
*
*revision
* v2_10 - L. Corbeil - rewrited for optimization,
* v2_10 removed e_vcubique
* v2_30 - L. Corbeil - renamed vte_ (no more called in gemntr)
* v2_31 - Lee V. - F_srclev,F_dstlev is calculated outside
*
*object
* see above id
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_dch Interpolated field
* F_sch source field
* F_srclev source levels
* F_dstlev destination levels
* F_var name of the variable
*
*----------------------------------------------------------------------
*
*implicites
#include "model_macros_f.h"
#include "dcst.cdk"
*
**
*
integer i,k,iter,niter,lev,lev_lin
integer top(n),bot(n),topcub(n),botcub(n),ref(n)
real*8 deltalev,prxd,prda,prdb,prsaf,prsbf,prsad,prsbd
*
* ---------------------------------------------------------------
*
**** General case, we'll care about VT later
*
* First, we find the level we are by squeezing the destination
* between increasing bot() and decreasing top(). We need log_2_(nks)
* iteration to squeeze it completely (each integer between 1 and
* nks can be expressed as a sum of power of 2 such as sum c_i 2^i
* where c_i = 0 or 1 and i lower or equal than log_2_(nks)
*
* WARNING
* niter calculation is ok for nks.lt. 2097152: should be ok for now...
* (Maybe the grid will be that precise in 2010!) (I don't even bother
* to add an if statement, for performance purpose...)
*
if (real(int(log(real(nks))/log(2.0))).eq.
$ log(real(nks))/log(2.0)) then
niter=int(log(real(nks))/log(2.0))
else
niter=int(log(real(nks))/log(2.0))+1
endif
*
* squeeze...
*
do k=1,nkd
do i=1,n
top(i)=nks
bot(i)=1
enddo
do iter=1,niter
do i=1,n
* divide by two (the old fashioned way...)
ref(i)=ishft(top(i)+bot(i),-1)
* adjust top or bot
if(F_dstlev(i,k).lt.F_srclev(i,ref(i))) then
top(i)=ref(i)
else
bot(i)=ref(i)
endif
enddo
enddo
* adjusting top and bot to ensure we can perform cubic interpolation
do i=1,n
botcub(i)=max(2,bot(i))
topcub(i)=min(nks-1,top(i))
enddo
* cubic or linear interpolation
do i=1,n
lev=botcub(i)
lev_lin=bot(i)
deltalev=(F_srclev(i,lev_lin+1)-F_srclev(i,lev_lin))
*
* Interpolation: if not enough points to perform cubic interpolation
* we use linear interpolation or persistency
*
if((lev.ne.lev_lin).or.(topcub(i).ne.top(i))) then
*
* persistancy of this interval
*
if(F_dstlev(i,k).le.F_srclev(i,1)) then
F_dch(i,k) = F_sch(i,1)
else if(F_dstlev(i,k).ge.F_srclev(i,nks)) then
F_dch(i,k) = F_sch(i,nks)
else
* linear interpolation
prxd=(F_dstlev(i,k)-F_srclev(i,lev_lin))/deltalev
F_dch(i,k) = (1.0-prxd)*F_sch(i,lev_lin)
$ +prxd*F_sch(i,lev_lin+1)
endif
else
* cubic interpolation
prxd = (F_dstlev(i,k)-F_srclev(i,lev_lin))/
$ deltalev
prda = ((F_sch(i,lev_lin+1)-F_sch(i,lev_lin-1))/
$ (F_srclev(i,lev_lin+1)-F_srclev(i,lev_lin-1))*
$ deltalev)
prdb = ((F_sch(i,lev_lin+2)-F_sch(i,lev_lin))/
$ (F_srclev(i,lev_lin+2)-F_srclev(i,lev_lin))*
$ deltalev)
prsaf= (1.0+2.0*prxd)*(1.0-prxd)*(1.0-prxd)
prsbf= (3.0-2.0*prxd)*prxd*prxd
prsad= prxd*(1.0-prxd)*(1.0-prxd)
prsbd= (1.0-prxd)*prxd*prxd
F_dch(i,k) = F_sch(i,lev_lin )*prsaf
$ +F_sch(i,lev_lin+1)*prsbf+prda*prsad
$ -prdb*prsbd
endif
enddo
enddo
*
* special case for VT
*
if(F_var.eq.'VT') then
do k=1,nkd
do i=1,n
if(F_srclev(i,nks).lt.F_dstlev(i,k)) then
F_dch(i,k) = F_sch(i,nks) * exp (
$ Dcst_rgasd_8*Dcst_stlo_8*(F_dstlev(i,k)-F_srclev(i,nks)) )
endif
enddo
enddo
*
endif
*
* ---------------------------------------------------------------
*
return
end