!-------------------------------------- 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 nest_bcs -
*
#include "model_macros_f.h"
*
subroutine nest_bcs () 3
implicit none
*
*author
* Michel Desgagne - Spring 2006
*
*revision
* v3_30 - Lee V. - initial version
*
*object
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "bcsdim.cdk"
#include "bcsgrds.cdk"
#include "bcsmem.cdk"
#include "vt1.cdk"
#include "nest.cdk"
#include "tr3d.cdk"
#include "lam.cdk"
#include "schm.cdk"
*
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
integer err,key(26),i,j,k,nvar,id
integer key0(Tr3d_ntr),key0_,key1(Tr3d_ntr),key1_, n
real tr,tr0
pointer (patr, tr(LDIST_SHAPE,*)),(patr0,tr0(LDIST_SHAPE,*))
*----------------------------------------------------------------------
*
if (north+south+west+east.lt.1) then
*
if (Lam_toptt_L) then
*
* Pilot the temperature for the whole top level
key(1 )= VMM_KEY(nest_t)
key(2 )= VMM_KEY(tt1)
nvar = 2
err = VMM_GET_VAR(nest_t)
err = VMM_GET_VAR(tt1)
*
do j=1,l_nj
do i=1,l_ni
tt1(i,j,1) = nest_t(i,j,1)
end do
end do
*
err = vmmuld(key,nvar)
*
endif
*
return
endif
*
key(1 )=VMM_KEY(nest_u)
key(2 )=VMM_KEY(nest_v)
key(3 )=VMM_KEY(nest_t)
key(4 )=VMM_KEY(nest_psd)
key(5 )=VMM_KEY(nest_pip)
key(6 )=VMM_KEY(nest_fip)
key(7 )=VMM_KEY(nest_td)
key(8 )=VMM_KEY(nest_fi)
key(9 )=VMM_KEY(nest_q)
key(10)=VMM_KEY(nest_s)
key(11)=VMM_KEY(nest_tp)
key(12)=VMM_KEY(ut1)
key(13)=VMM_KEY(vt1)
key(14)=VMM_KEY(tt1)
key(15)=VMM_KEY(psdt1)
key(16)=VMM_KEY(pipt1)
key(17)=VMM_KEY(fipt1)
key(18)=VMM_KEY(tdt1)
key(19)=VMM_KEY(fit1)
key(20)=VMM_KEY(qt1)
key(21)=VMM_KEY(st1)
key(22)=VMM_KEY(tpt1)
nvar = 22
*
if (.not.Schm_hydro_L) then
key(23)=VMM_KEY(nest_w)
key(24)=VMM_KEY(nest_mu)
key(25)=VMM_KEY(wt1)
key(26)=VMM_KEY(mut1)
nvar = 26
endif
*
err = vmmlod(key,nvar)
err = VMM_GET_VAR(nest_u)
err = VMM_GET_VAR(nest_v)
err = VMM_GET_VAR(nest_t)
err = VMM_GET_VAR(nest_psd)
err = VMM_GET_VAR(nest_pip)
err = VMM_GET_VAR(nest_fip)
err = VMM_GET_VAR(nest_td)
err = VMM_GET_VAR(nest_fi)
err = VMM_GET_VAR(nest_q)
err = VMM_GET_VAR(nest_s)
err = VMM_GET_VAR(nest_tp)
err = VMM_GET_VAR(ut1)
err = VMM_GET_VAR(vt1)
err = VMM_GET_VAR(tt1)
err = VMM_GET_VAR(psdt1)
err = VMM_GET_VAR(pipt1)
err = VMM_GET_VAR(fipt1)
err = VMM_GET_VAR(tdt1)
err = VMM_GET_VAR(fit1)
err = VMM_GET_VAR(qt1)
err = VMM_GET_VAR(st1)
err = VMM_GET_VAR(tpt1)
if (.not.Schm_hydro_L) then
err = VMM_GET_VAR(nest_w)
err = VMM_GET_VAR(nest_mu)
err = VMM_GET_VAR(wt1)
err = VMM_GET_VAR(mut1)
endif
*
if (l_north) then
do k=1,G_nk
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
tt1 (i,j,k) = nest_t (i,j,k)
psdt1(i,j,k) = nest_psd(i,j,k)
pipt1(i,j,k) = nest_pip(i,j,k)
fipt1(i,j,k) = nest_fip(i,j,k)
tdt1 (i,j,k) = nest_td (i,j,k)
fit1 (i,j,k) = nest_fi (i,j,k)
qt1 (i,j,k) = nest_q (i,j,k)
tpt1 (i,j,k) = nest_tp (i,j,k)
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_niu
ut1 (i,j,k) = nest_u (i,j,k)
end do
end do
do j=l_nj-pil_n,l_njv
do i=1,l_ni
vt1 (i,j,k) = nest_v (i,j,k)
end do
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
st1 (i,j) = nest_s (i,j)
end do
end do
if (.not. Schm_hydro_L) then
do k=1,G_nk
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
wt1 (i,j,k) = nest_w (i,j,k)
mut1(i,j,k) = nest_mu(i,j,k)
end do
end do
end do
endif
endif
*
if (l_east) then
do k=1,G_nk
do j=1,l_nj
do i=l_ni-pil_e+1,l_ni
tt1 (i,j,k) = nest_t (i,j,k)
psdt1(i,j,k) = nest_psd(i,j,k)
pipt1(i,j,k) = nest_pip(i,j,k)
fipt1(i,j,k) = nest_fip(i,j,k)
tdt1 (i,j,k) = nest_td (i,j,k)
fit1 (i,j,k) = nest_fi (i,j,k)
qt1 (i,j,k) = nest_q (i,j,k)
tpt1 (i,j,k) = nest_tp (i,j,k)
end do
end do
do j=1,l_nj
do i=l_ni-pil_e,l_niu
ut1 (i,j,k) = nest_u (i,j,k)
end do
end do
do j=1,l_njv
do i=l_ni-pil_e+1,l_ni
vt1 (i,j,k) = nest_v (i,j,k)
end do
end do
end do
do j=1,l_nj
do i=l_ni-pil_e+1,l_ni
st1 (i,j) = nest_s (i,j)
end do
end do
if (.not. Schm_hydro_L) then
do k=1,G_nk
do j=1,l_nj
do i=l_ni-pil_e+1,l_ni
wt1 (i,j,k) = nest_w (i,j,k)
mut1(i,j,k) = nest_mu(i,j,k)
end do
end do
end do
endif
endif
*
if (l_south) then
do k=1,G_nk
do j=1,pil_s
do i=1,l_ni
vt1 (i,j,k) = nest_v (i,j,k)
tt1 (i,j,k) = nest_t (i,j,k)
psdt1(i,j,k) = nest_psd(i,j,k)
pipt1(i,j,k) = nest_pip(i,j,k)
fipt1(i,j,k) = nest_fip(i,j,k)
tdt1 (i,j,k) = nest_td (i,j,k)
fit1 (i,j,k) = nest_fi (i,j,k)
qt1 (i,j,k) = nest_q (i,j,k)
tpt1 (i,j,k) = nest_tp (i,j,k)
end do
end do
do j=1,pil_s
do i=1,l_niu
ut1 (i,j,k) = nest_u (i,j,k)
end do
end do
end do
do j=1,pil_s
do i=1,l_ni
st1 (i,j) = nest_s (i,j)
end do
end do
if (.not. Schm_hydro_L) then
do k=1,G_nk
do j=1,pil_s
do i=1,l_ni
wt1 (i,j,k) = nest_w (i,j,k)
mut1(i,j,k) = nest_mu(i,j,k)
end do
end do
end do
endif
endif
*
if (l_west) then
do k=1,G_nk
do j=1,l_nj
do i=1,pil_w
ut1 (i,j,k) = nest_u (i,j,k)
tt1 (i,j,k) = nest_t (i,j,k)
psdt1(i,j,k) = nest_psd(i,j,k)
pipt1(i,j,k) = nest_pip(i,j,k)
fipt1(i,j,k) = nest_fip(i,j,k)
tdt1 (i,j,k) = nest_td (i,j,k)
fit1 (i,j,k) = nest_fi (i,j,k)
qt1 (i,j,k) = nest_q (i,j,k)
tpt1 (i,j,k) = nest_tp (i,j,k)
end do
end do
do j=1,l_njv
do i=1,pil_w
vt1 (i,j,k) = nest_v (i,j,k)
end do
end do
end do
do j=1,l_nj
do i=1,pil_w
st1 (i,j) = nest_s (i,j)
end do
end do
if (.not. Schm_hydro_L) then
do k=1,G_nk
do j=1,l_nj
do i=1,pil_w
wt1 (i,j,k) = nest_w (i,j,k)
mut1(i,j,k) = nest_mu(i,j,k)
end do
end do
end do
endif
endif
*
if (Lam_toptt_L) then
*
* Pilot the temperature for the whole top level
do j=1,l_nj
do i=1,l_ni
tt1(i,j,1) = nest_t(i,j,1)
end do
end do
endif
*
err = vmmuld(key,nvar)
*
key1_ = VMM_KEY (nest_tr)
key0_ = VMM_KEY (trt1)
do n=1,Tr3d_ntr
key1(n) = key1_ + n
key0(n) = key0_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1,Tr3d_ntr)
err = vmmlod(key0,Tr3d_ntr)
do n=1,Tr3d_ntr
id = (n-1)*bcs_sz+1
err = vmmget(key1(n),patr ,tr )
err = vmmget(key0(n),patr0,tr0)
if (l_north) then
do k=1,G_nk
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
tr0 (i,j,k) = tr (i,j,k)
enddo
enddo
enddo
endif
if (l_east) then
do k=1,G_nk
do j=1,l_nj
do i=l_ni-pil_e+1,l_ni
tr0 (i,j,k) = tr (i,j,k)
enddo
enddo
enddo
endif
if (l_south) then
do k=1,G_nk
do j=1,pil_s
do i=1,l_ni
tr0 (i,j,k) = tr (i,j,k)
enddo
enddo
enddo
endif
if (l_west) then
do k=1,G_nk
do j=1,l_nj
do i=1,pil_w
tr0 (i,j,k) = tr (i,j,k)
enddo
enddo
enddo
endif
enddo
err = vmmuld(key1,Tr3d_ntr)
err = vmmuld(key0,Tr3d_ntr)
endif
*
*----------------------------------------------------------------------
return
1000 format (/,19('#'),' NEST_BCS STAT ',i6,1X,19('#'))
end