!-------------------------------------- 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 --------------------------------------
*** casc_hvi_topo - take incoming lo-res data TOPO, interpolate to hi-res data
* and place into the pieces of the BCS target grid as
* described in bcs_did
*
#include "model_macros_f.h"
*
subroutine casc_hvi_topo (xpqd,ypqd,xpud,ypvd,xpqs,ypqs,xpus,ypvs, 4,3
$ fip1,fip2,fiu1,fiu2,fiv1,fiv2,fin,
$ n1,n2,n3,n4,d1,d2,nid,njd,
$ nis,njs,b1_L,b2_L)
*
implicit none
*
logical b1_L,b2_L
integer n1,n2,n3,n4,d1,d2,nid,njd,nis,njs
real*8 xpqd(*),ypqd(*),xpud(*),ypvd(*)
real*8 xpqs(*),ypqs(*),xpus(*),ypvs(*)
real fin(nis*njs),
$ fip1(n1:n2,n3:n4),fip2(n1:n2,n3:n4),
$ fiu1(n1:n2,n3:n4),fiu2(n1:n2,n3:n4),
$ fiv1(n1:n2,n3:n4),fiv2(n1:n2,n3:n4)
*
*author M.Tanguay
*
*revision
* v3_31 - Tanguay M. - initial version for GEMDM
* v3_31 - Tanguay M. - Mix PILOT and ANAL mountains when BCS/3DF
*
#include "bcsdim.cdk"
#include "bcsgrds.cdk"
#include "bcsmem.cdk"
#include "lam.cdk"
#include "lun.cdk"
*
*-----------------------------------------------------------------------
integer ii,i,j,ngd
integer, dimension (:) , allocatable :: idx,idu,idy
real, dimension (:) , allocatable :: fipr,fiur,fivr
real, dimension (:,:) , allocatable :: fip3,fiu3,fiv3
real*8, dimension (: ) , allocatable :: cxa,cxb,cxc,cxd,
$ cua,cub,cuc,cud,
$ cya,cyb,cyc,cyd
*-----------------------------------------------------------------------
*
ngd = nid * njd
if (ngd.le.0) return
*
allocate ( idx(nid), idu(max(nid,njd)), idy(njd) )
allocate ( cxa(nid),cxb(nid),cxc(nid),cxd(nid),
$ cua(max(nid,njd)),cub(max(nid,njd)),
$ cuc(max(nid,njd)),cud(max(nid,njd)),
$ cya(njd),cyb(njd),cyc(njd),cyd(njd))
*
allocate (fipr(ngd),fiur(ngd),fivr(ngd))
*
* Horizontal interpolation (xpqs,ypqs) ===> (xpqd,ypqd)
* -----------------------------------------------------
call grid_to_grid_coef(xpqd,nid,xpqs,nis,idx,cxa,cxb,cxc,cxd,Lam_hint_S)
call grid_to_grid_coef(ypqd,njd,ypqs,njs,idy,cya,cyb,cyc,cyd,Lam_hint_S)
*
call hinterpo (fipr,nid,njd,fin,nis,njs,1,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Horizontal interpolation (xpqs,ypqs) ===> (xpud,ypqd)
* -----------------------------------------------------
call grid_to_grid_coef (xpud,nid,xpqs,nis,idu,cua,cub,cuc,cud,Lam_hint_S)
*
call hinterpo (fiur,nid,njd,fin,nis,njs,1,
$ idu,idy,cua,cub,cuc,cud,cya,cyb,cyc,cyd,Lam_hint_S)
* Horizontal interpolation (xpqs,ypqs) ===> (xpqd,ypvd)
* -----------------------------------------------------
call grid_to_grid_coef (ypvd,njd,ypqs,njs,idu,cua,cub,cuc,cud,Lam_hint_S)
*
call hinterpo (fivr,nid,njd,fin,nis,njs,1,
$ idx,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,Lam_hint_S)
*
deallocate (idx,idy,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,cya,cyb,cyc,cyd)
*
allocate ( fip3(n1:d1+n2,n3:d2+n4),
$ fiu3(n1:d1+n2,n3:d2+n4),
$ fiv3(n1:d1+n2,n3:d2+n4))
do j=1,njd
do i=1,nid
ii=(j-1)*nid+i
fip3(i+n1-1,j+n3-1)=fipr(ii)
fiu3(i+n1-1,j+n3-1)=fiur(ii)
fiv3(i+n1-1,j+n3-1)=fivr(ii)
enddo
enddo
*
* Place in BCS space
* ------------------
if (b1_L) then
do j=n3,n4
do i=n1,n2
fip1(i,j) = fip3(i,j)
fiu1(i,j) = fiu3(i,j)
fiv1(i,j) = fiv3(i,j)
enddo
enddo
endif
*
if (b2_L) then
do j=n3,n4
do i=n1,n2
fip2(i,j) = fip3(i+d1,j+d2)
fiu2(i,j) = fiu3(i+d1,j+d2)
fiv2(i,j) = fiv3(i+d1,j+d2)
end do
end do
endif
*
deallocate (fipr,fiur,fivr)
deallocate (fip3,fiu3,fiv3)
*
*-----------------------------------------------------------------------
return
end
*