copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r casc_hvi
*
subroutine casc_hvi (trname,trname_a, 4,27
$ xpqd,ypqd,xpud,ypvd,xpqs,ypqs,xpus,ypvs,
$ qq1,qq2,uu1,uu2,vv1,vv2,ww1,ww2,tt1,tt2,hm1,hm2,cl1,cl2,
$ mxn,uun,vvn,wzn,bun,prn,hun,cln,n1,n2,n3,n4,d1,d2,d3,d4,
$ lnk,nid,njd,nis,njs,nka,ntra,b1,b2)
implicit none
*
character*8 trname(*),trname_a(*)
logical b1,b2
integer n1,n2,n3,n4,d1,d2,d3,d4,lnk,nid,njd,nis,njs,nka,ntra
real*8 xpqd(*),ypqd(*),xpud(*),ypvd(*)
real*8 xpqs(*),ypqs(*),xpus(*),ypvs(*)
real mxn(*),uun(*),vvn(*),wzn(*),bun(*),prn(*),hun(*),cln(*),
$ qq1(n1:n2,n3:n4,0:lnk), qq2(n1:n2,n3:n4,0:lnk),
$ uu1(n1:n2,n3:n4,*),uu2(n1:n2,n3:n4,*),
$ vv1(n1:n2,n3:n4,*),vv2(n1:n2,n3:n4,*),
$ ww1(n1:n2,n3:n4,*),ww2(n1:n2,n3:n4,*),
$ tt1(n1:n2,n3:n4,*),tt2(n1:n2,n3:n4,*),
$ hm1(n1:n2,n3:n4,*),hm2(n1:n2,n3:n4,*),
$ cl1(n1:n2,n3:n4,lnk,*),cl2(n1:n2,n3:n4,lnk,*)
*
#include "dynmem.cdk"
#include "bcsgrds.cdk"
#include "hinterpo.cdk"
#include "vinterpo.cdk"
*
integer i,j,k,n,iuv,itt,iwz,ngd,nga,err
integer, dimension (:), allocatable :: ktop,kbot,idx,idu,idy
real, dimension (:,:), allocatable :: mxr,uur,vvr,wzr,bur,
$ hur,hgeow,hgeot,hgeom,hgeow_anal,hgeot_anal,hgeom_anal
real, dimension (:,:,:), allocatable :: prr,clr,w1,w2,w3,w4,w5,w6
real*8, dimension (: ), allocatable ::
$ cxa,cxb,cxc,cxd,cua,cub,cuc,cud,cya,cyb,cyc,cyd
*
*-----------------------------------------------------------------------
*
ngd = nid * njd
nga = nis * njs
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))
*
call grid_to_grid_coef(xpqd,nid,xpqs,nis,idx,cxa,cxb,cxc,cxd,
$ hint_model)
call grid_to_grid_coef(ypqd,njd,ypqs,njs,idy,cya,cyb,cyc,cyd,
$ hint_model)
*
allocate (mxr(ngd,2),uur(ngd,nka+1),vvr(ngd,nka+1),wzr(ngd,nka),
$ bur(ngd,nka),prr(n1:d1+n2,n3:d2+n4,nka+1),hur(ngd,nka),
$ clr(ngd,nka,ntra))
*
* Perform horizontal interpolations
*
call hinterpo (mxr,nid,njd,mxn,nis,njs,2,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,hint_model)
call hinterpo (wzr,nid,njd,wzn,nis,njs,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,hint_model)
call hinterpo (bur,nid,njd,bun,nis,njs,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,hint_model)
call hinterpo (prr,nid,njd,prn,nis,njs,nka+1,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,hint_model)
call hinterpo (hur,nid,njd,hun,nis,njs,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,hint_model)
*
do k=1,ntra
if (trname_a(k).ne.'!@@NOT@@')
$ call hinterpo (clr(1,1,k),nid,njd,cln((k-1)*nga*nka+1),nis,njs,
$ nka,idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,hint_model)
end do
*
call grid_to_grid_coef (xpud,nid,xpus,nis,idu,cua,cub,cuc,cud,
$ hint_model)
call hinterpo (uur(1,2),nid,njd,uun,nis,njs,nka,
$ idu,idy,cua,cub,cuc,cud,cya,cyb,cyc,cyd,hint_model)
call grid_to_grid_coef (ypvd,njd,ypvs,njs,idu,cua,cub,cuc,cud,
$ hint_model)
call hinterpo (vvr(1,2),nid,njd,vvn,nis,njs,nka,
$ idx,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,hint_model)
deallocate (idx,idy,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,
$ cya,cyb,cyc,cyd)
*
uur(:,1) = uur(:,2)
vvr(:,1) = vvr(:,2)
*
* Preparation for vertical interpolation
*
iuv = 1
itt = ngd*lnk*2 + 1
iwz = ngd*lnk*4 + 1
call hpalloc (paposit,ngd*lnk*6 , err,1)
call hpalloc (pahuv ,ngd*(nka+4) , err,1)
call hpalloc (pahtt ,ngd*(nka+4) , err,1)
call hpalloc (pahww ,ngd*(nka+4) , err,1)
*
allocate (hgeow(ngd,lnk),hgeot(ngd,lnk),hgeom(ngd,0:lnk),
$ hgeow_anal(ngd,nka),hgeot_anal(ngd,nka),hgeom_anal(ngd, nka+1))
*
* Compute target heights in hgeow, hgeot and hgeom
*
call hauteur (hgeow ,'HW',mxr,ngd,1,lnk)
call hauteur (hgeot ,'HT',mxr,ngd,1,lnk)
call hauteur (hgeom(1,1),'HM',mxr,ngd,1,lnk)
do i=1,ngd
hgeom(i,0) = mxr(i,1)
enddo
*
* Compute reference (input data) heights in hgeow_anal,
* hgeot_anal and hgeom_anal.
*
call ref_h2 ( hgeow_anal,hgeot_anal,hgeom_anal,mxr,zta,ngd,nka )
*
* Precompute vertical interpolation positions
*
allocate (ktop(ngd*lnk), kbot(ngd*lnk))
call posiz3 (posit(iuv),huv,hgeom_anal,hgeom(1,1),ktop,kbot,
$ ngd,lnk,nka+1)
call posiz3 (posit(itt),htt,hgeot_anal,hgeot ,ktop,kbot,
$ ngd,lnk,nka )
call posiz3 (posit(iwz),hww,hgeow_anal,hgeow ,ktop,kbot,
$ ngd,lnk,nka )
deallocate ( ktop,kbot,hgeow,hgeow_anal, hgeom_anal )
*
* Perform vertical interpolations and transfer into model space
*
allocate ( w1(n1:d1+n2,n3:d2+n4,(lnk+1)),
$ w2(n1:d1+n2,n3:d2+n4,(lnk+1)),
$ w3(n1:d1+n2,n3:d2+n4,(lnk+1)),
$ w4(n1:d1+n2,n3:d2+n4,(lnk+1)),
$ w5(n1:d1+n2,n3:d2+n4,(lnk+1)),
$ w6(n1:d1+n2,n3:d2+n4,(lnk+1)) )
*
call vertint3 ( w1,uur,posit(iuv),huv,ngd,lnk,nka+1)
call vertint3 ( w2,vvr,posit(iuv),huv,ngd,lnk,nka+1)
call vertint3 ( w3,wzr,posit(iwz),hww,ngd,lnk,nka )
call vertint3 ( w4,hur,posit(itt),htt,ngd,lnk,nka )
call vertint3 ( w5,bur,posit(itt),htt,ngd,lnk,nka )
call vertint3 ( w6,prr,posit(iuv),huv,ngd,lnk,nka+1)
call corbusfc ( w5,hgeot,hgeom,hgeot_anal,ngd,lnk)
if (b1) then
do k=1,lnk
do j=n3,n4
do i=n1,n2
uu1(i,j,k) = w1(i,j,k) / sqrt(sby(i,j))
vv1(i,j,k) = w2(i,j,k) / sqrt(sbx(i,j))
ww1(i,j,k) = w3(i,j,k)
hm1(i,j,k) = w4(i,j,k)
tt1(i,j,k) = w5(i,j,k)
qq1(i,j,k) = w6(i,j,k)
end do
end do
end do
do j=n3,n4
do i=n1,n2
uu1(i,j,lnk) = uu1(i,j,lnk-1)
vv1(i,j,lnk) = vv1(i,j,lnk-1)
qq1(i,j,0 ) = prr(i,j,1)
end do
end do
endif
*
if (b2) then
do k=1,lnk
do j=n3,n4
do i=n1,n2
uu2(i,j,k) = w1(i+d1,j+d2,k) / sqrt(sby(i+d3,j+d4))
vv2(i,j,k) = w2(i+d1,j+d2,k) / sqrt(sbx(i+d3,j+d4))
ww2(i,j,k) = w3(i+d1,j+d2,k)
hm2(i,j,k) = w4(i+d1,j+d2,k)
tt2(i,j,k) = w5(i+d1,j+d2,k)
qq2(i,j,k) = w6(i+d1,j+d2,k)
end do
end do
end do
do j=n3,n4
do i=n1,n2
uu2(i,j,lnk) = uu2(i,j,lnk-1)
vv2(i,j,lnk) = vv2(i,j,lnk-1)
qq2(i,j,0 ) = prr(i+d1,j+d2,1)
end do
end do
endif
*
do n=1,ntr
j=-1
do k=1,ntra
if (trname(n).eq.trname_a(k)) j=k
end do
if (j.gt.0) then
call vertint3 (w1,clr(1,1,j),posit(itt),htt,ngd,lnk,nka)
if (b1) then
do k=1,lnk
do j=n3,n4
do i=n1,n2
cl1(i,j,k,n) = w1(i,j,k)
end do
end do
end do
endif
if (b2) then
do k=1,lnk
do j=n3,n4
do i=n1,n2
cl2(i,j,k,n) = w1(i+d1,j+d2,k)
end do
end do
end do
endif
else
if (b1) cl1(:,:,:,n) = 0.
if (b2) cl2(:,:,:,n) = 0.
endif
end do
*
deallocate (mxr,uur,vvr,wzr,bur,prr,hur,clr,hgeot,hgeom,
$ hgeot_anal,w1,w2,w3,w4,w5,w6)
call hpdeallc (paposit,err,1)
call hpdeallc (pahuv ,err,1)
call hpdeallc (pahtt ,err,1)
call hpdeallc (pahww ,err,1)
paposit = 0
pahuv = 0
pahtt = 0
pahww = 0
*
*-----------------------------------------------------------------------
return
end
*