!-------------------------------------- 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 --------------------------------------
!
subroutine hintvec(psrcuu,kscolu,ksrcuugid,psrcvv,kscolv 1
& ,ksrcvvgid,ptrguu,ktcolu,ktrguugid,ptrgvv
& ,ktcolv,ktrgvvgid,klev,cddegint)
#if defined (DOC)
*
***s/r hintvec
*
*
* Author : S. Pellerin ARMA/AES Avril 2000
* Revision:
*
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
*
** Purpose: vectorial horizontal interpolation
*
*
*
*Arguments
* input:
* psrcuu(kscolu,klev) : source U componant
* kscolu : number of collumns of source U componant
* ksrcuugid : grid id of source U componant
* psrcvv(kscolv,klev) : source V componant
* kscolv : number of collumns of source V componant
* ksrcvvgid : grid id of source V componant
* ktcolu : number of collumns of target U componant
* ktrguugid : grid id of target U componant
* ktcolv : number of collumns of target V componant
* ktrgvvgid : grid id of target V componant
* klev : number of horizontal slabs to interpolate
* cddegint : degree of horizontal interpolation
* ouput:
* ptrguu(ktcolu,klev) : target U componant
* ptrgvv(ktcolv,klev) : target V componant
*
#endif
implicit none
*implicits
integer ksrcuugid,ktrguugid,ksrcvvgid,ktrgvvgid
integer kscolu,kscolv,ktcolu,ktcolv,klev
real*8 psrcuu(kscolu,klev),ptrguu(ktcolu,klev),psrcvv(kscolv,klev)
real*8 ptrgvv(ktcolv,klev)
character*(*) cddegint
c
c----------------------------------------------------------
c
integer ier,ezsetopt,vezuvint,ezdefset,ezgprm,iset
integer clgrtyp,ini,inj,iig1,iig2,iig3,iig4,ji,itrg,jk
real*8 zsrc(1),ztrguu(1),ztrgvv(1)
pointer (pzsrc,zsrc)
pointer (pztrguu,ztrguu)
pointer (pztrgvv,ztrgvv)
c
c Setting degree of horizontal interpolations
c
ier = ezsetopt('INTERP_DEGREE',cddegint)
c
iset = ezdefset(ktrguugid,ksrcuugid)
if (ktrguugid .eq. ktrgvvgid) then
if (ksrcuugid .eq. ksrcvvgid) then
do jk = 1,klev
ier = vezuvint(ptrguu(1,jk),ptrgvv(1,jk),psrcuu(1,jk)
& ,psrcvv(1,jk),ktcolu,kscolu)
enddo
else
call hpalloc(pztrguu,ktcolu,ier,8)
call hpalloc(pztrgvv,ktcolu,ier,8)
c
c .. from UU source component
c
call hpalloc(pzsrc,kscolu,ier,8)
c
do ji = 1,kscolu
zsrc(ji) = 0.0
enddo
c
do jk = 1,klev
ier = vezuvint(ptrguu(1,jk),ptrgvv(1,jk),psrcuu(1,jk),zsrc,
$ ktcolu,kscolu)
enddo
c
call hpdeallc(pzsrc,ier,1)
c
c .. from VV source component
c
iset = ezdefset(ktrguugid,ksrcvvgid)
c
call hpalloc(pzsrc,kscolv,ier,8)
c
do ji = 1,kscolv
zsrc(ji) = 0.0
enddo
c
do jk = 1,klev
ier = vezuvint(ztrguu,ztrgvv,zsrc,psrcvv(1,jk),
$ ktcolu,kscolv)
do ji = 1, ktcolu
ptrguu(ji,jk) = ptrguu(ji,jk) + ztrguu(ji)
enddo
do ji = 1, ktcolv
ptrgvv(ji,jk) = ptrgvv(ji,jk) + ztrgvv(ji)
enddo
enddo
c
call hpdeallc(pzsrc,ier,1)
c
call hpdeallc(pztrguu,ier,1)
call hpdeallc(pztrgvv,ier,1)
endif
else
c
c UU interpolation ..
c
call hpalloc(pztrguu,ktcolu,ier,8)
call hpalloc(pztrgvv,ktcolu,ier,8)
c
c .. from UU source component
c
if (ksrcuugid .eq. ksrcvvgid) then
do jk = 1,klev
ier = vezuvint(ptrguu(1,jk),ztrgvv,psrcuu(1,jk),psrcvv(1,jk)
& ,ktcolu,kscolu)
enddo
else
call hpalloc(pzsrc,kscolu,ier,8)
c
do ji = 1,kscolu
zsrc(ji) = 0.0
enddo
c
do jk = 1,klev
ier = vezuvint(ptrguu(1,jk),ztrgvv,psrcuu(1,jk),zsrc,
$ ktcolu,kscolu)
enddo
c
call hpdeallc(pzsrc,ier,1)
c
c .. from VV source component
c
iset = ezdefset(ktrguugid,ksrcvvgid)
c
call hpalloc(pzsrc,kscolv,ier,8)
c
do ji = 1,kscolv
zsrc(ji) = 0.0
enddo
c
do jk = 1,klev
ier = vezuvint(ztrguu,ztrgvv,zsrc,psrcvv(1,jk),
$ ktcolu,kscolv)
do ji = 1, ktcolu
ptrguu(ji,jk) = ptrguu(ji,jk) + ztrguu(ji)
enddo
enddo
c
call hpdeallc(pzsrc,ier,1)
endif
c
call hpdeallc(pztrguu,ier,1)
call hpdeallc(pztrgvv,ier,1)
c VV interpolation ..
c
call hpalloc(pztrguu,ktcolv,ier,8)
call hpalloc(pztrgvv,ktcolv,ier,8)
c
c .. from UU source component
c
iset = ezdefset(ktrgvvgid,ksrcuugid)
if (ksrcuugid .eq. ksrcvvgid) then
do jk = 1,klev
ier = vezuvint(ztrguu,ptrgvv(1,jk),psrcuu(1,jk),psrcvv(1,jk)
& ,ktcolv,kscolu)
enddo
else
call hpalloc(pzsrc,kscolu,ier,8)
c
do ji = 1,kscolu
zsrc(ji) = 0.0
enddo
c
do jk = 1,klev
ier = vezuvint(ztrguu,ptrgvv(1,jk),psrcuu(1,jk),zsrc,
$ ktcolv,kscolu)
enddo
c
call hpdeallc(pzsrc,ier,1)
c
c .. from VV source component
c
iset = ezdefset(ktrgvvgid,ksrcvvgid)
c
call hpalloc(pzsrc,kscolv,ier,8)
c
do ji = 1,kscolv
zsrc(ji) = 0.0
enddo
c
do jk = 1,klev
ier = vezuvint(ztrguu,ztrgvv,zsrc,psrcvv(1,jk),
$ ktcolv,kscolv)
do ji = 1, ktcolv
ptrgvv(ji,jk) = ptrgvv(ji,jk) + ztrgvv(ji)
enddo
enddo
c
call hpdeallc(pzsrc,ier,1)
endif
c
call hpdeallc(pztrguu,ier,1)
call hpdeallc(pztrgvv,ier,1)
endif
c
return
end