!-------------------------------------- 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 ta2t1tx - Fetch variables ta into t1 and tx
*
#include "model_macros_f.h"
*
subroutine ta2t1tx 1
implicit none
*
*author
* Alain Patoine - april 94
*
*revision
*
*object
* v2_00 - Desgagne M. - initial MPI version
* v2_30 - Edouard S. - remove pi' at the top
* v2_31 - Desgagne M. - remove treatment of HU and QC and
* re-introduce tracers
* v3_00 - Desgagne & Lee - Lam configuration
* v3_21 - Lee V. - remove TR2D
* v3_31 - McTaggart-Cowan R.- correction for Vtopo mode in digflt
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "schm.cdk"
#include "p_geof.cdk"
#include "vta.cdk"
#include "vt1.cdk"
#include "vtx.cdk"
#include "nest.cdk"
#include "tr3d.cdk"
#include "itf_phy_buses.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
integer err, key(28), i, j, k, n, key1_, keya_, key1(Tr3d_ntr),
$ keya(Tr3d_ntr), nvar
real tr1,tra
pointer (patr1, tr1(LDIST_SHAPE,*)),(patra, tra(LDIST_SHAPE,*))
real busper(max(1,p_bper_siz)), buf(l_ni,G_nk)
real, allocatable, dimension(:,:,:,:) :: tr2,tr3
**
* ---------------------------------------------------------------
*
*C 1. Fetch variables ta into t1 and tx
* ---------------------------------
*
key(1) = VMM_KEY(uta )
key(2) = VMM_KEY(ut1 )
key(3) = VMM_KEY(vta )
key(4) = VMM_KEY(vt1 )
key(5) = VMM_KEY(tdta )
key(6) = VMM_KEY(tdt1 )
key(7) = VMM_KEY(fita )
key(8) = VMM_KEY(fit1 )
key(9) = VMM_KEY(fipta)
key(10) = VMM_KEY(fipt1)
key(11) = VMM_KEY(tta )
key(12) = VMM_KEY(tt1 )
key(13) = VMM_KEY(qta )
key(14) = VMM_KEY(qt1 )
key(15) = VMM_KEY(tpta )
key(16) = VMM_KEY(tpt1 )
key(17) = VMM_KEY(pipta)
key(18) = VMM_KEY(pipt1)
key(19) = VMM_KEY(tplta)
key(20) = VMM_KEY(tplt1)
key(21) = VMM_KEY(psdta)
key(22) = VMM_KEY(psdt1)
key(23) = VMM_KEY(sta )
key(24) = VMM_KEY(st1 )
key(25) = VMM_KEY(gpta )
key(26) = VMM_KEY(gptx )
key(27) = VMM_KEY(topoa)
key(28) = VMM_KEY(topo )
*
err = vmmlod(key,size(key))
err = VMM_GET_VAR(uta )
err = VMM_GET_VAR(ut1 )
err = VMM_GET_VAR(vta )
err = VMM_GET_VAR(vt1 )
err = VMM_GET_VAR(tdta )
err = VMM_GET_VAR(tdt1 )
err = VMM_GET_VAR(fita )
err = VMM_GET_VAR(fit1 )
err = VMM_GET_VAR(fipta)
err = VMM_GET_VAR(fipt1)
err = VMM_GET_VAR(tta )
err = VMM_GET_VAR(tt1 )
err = VMM_GET_VAR(qta )
err = VMM_GET_VAR(qt1 )
err = VMM_GET_VAR(tpta )
err = VMM_GET_VAR(tpt1 )
err = VMM_GET_VAR(pipta)
err = VMM_GET_VAR(pipt1)
err = VMM_GET_VAR(tplta)
err = VMM_GET_VAR(tplt1)
err = VMM_GET_VAR(psdta)
err = VMM_GET_VAR(psdt1)
err = VMM_GET_VAR(sta )
err = VMM_GET_VAR(st1 )
err = VMM_GET_VAR(gpta )
err = VMM_GET_VAR(gptx )
err = VMM_GET_VAR(topoa)
err = VMM_GET_VAR(topo )
*
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
ut1 (i,j,k) = uta (i,j,k)
vt1 (i,j,k) = vta (i,j,k)
tdt1 (i,j,k) = tdta (i,j,k)
fit1 (i,j,k) = fita (i,j,k)
fipt1(i,j,k) = fipta(i,j,k)
tt1 (i,j,k) = tta (i,j,k)
qt1 (i,j,k) = qta (i,j,k)
tpt1 (i,j,k) = tpta (i,j,k)
pipt1(i,j,k) = pipta(i,j,k)
tplt1(i,j,k) = tplta(i,j,k)
psdt1(i,j,k) = psdta(i,j,k)
gptx (i,j,k) = gpta (i,j,k)
enddo
enddo
enddo
*
do j= 1, l_nj
do i= 1, l_ni
st1 (i,j) = sta (i,j)
topo (i,j) = topoa(i,j)
enddo
enddo
*
err = vmmuld(-1,0)
*
********************************************************************
* Non-hydrostatic model fields
********************************************************************
*
if ( .not. Schm_hydro_L ) then
*
key(1) = VMM_KEY(wta )
key(2) = VMM_KEY(wt1 )
key(3) = VMM_KEY(qpta )
key(4) = VMM_KEY(qpt1 )
key(5) = VMM_KEY(multa)
key(6) = VMM_KEY(multx)
key(7) = VMM_KEY(muta )
key(8) = VMM_KEY(mut1 )
err = vmmlod(key,8)
err = VMM_GET_VAR(wta )
err = VMM_GET_VAR(wt1 )
err = VMM_GET_VAR(qpta )
err = VMM_GET_VAR(qpt1 )
err = VMM_GET_VAR(multa)
err = VMM_GET_VAR(multx)
err = VMM_GET_VAR(muta )
err = VMM_GET_VAR(mut1 )
*
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
wt1 (i,j,k) = wta (i,j,k)
qpt1 (i,j,k) = qpta (i,j,k)
multx(i,j,k) = multa(i,j,k)
mut1 (i,j,k) = muta (i,j,k)
enddo
enddo
enddo
*
err = vmmuld(-1,0)
*
endif
*
key1_ = VMM_KEY (trt1)
keya_ = VMM_KEY (trta)
do n=1,Tr3d_ntr
key1(n) = key1_ + n
keya(n) = keya_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1,Tr3d_ntr)
err = vmmlod(keya,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1(n),patr1,tr1)
err = vmmget(keya(n),patra,tra)
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
tr1(i,j,k) = tra(i,j,k)
end do
end do
end do
end do
err = vmmuld(key1,Tr3d_ntr)
err = vmmuld(keya,Tr3d_ntr)
endif
*
*
*******************************************************************
* Physics fields
*******************************************************************
*
if ( Schm_phyms_L ) then
Phy_busper3D = Phy_busper3D_digf
deallocate (Phy_busper3D_digf)
endif
*
if (G_lam ) then
*
if (north+south+west+east.lt.1) return
*
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(uta)
key(13)=VMM_KEY(vta)
key(14)=VMM_KEY(tta)
key(15)=VMM_KEY(psdta)
key(16)=VMM_KEY(pipta)
key(17)=VMM_KEY(fipta)
key(18)=VMM_KEY(tdta)
key(19)=VMM_KEY(fita)
key(20)=VMM_KEY(qta)
key(21)=VMM_KEY(sta)
key(22)=VMM_KEY(tpta)
nvar = 22
*
if (.not.Schm_hydro_L) then
key(23)=VMM_KEY(nest_w)
key(24)=VMM_KEY(nest_mu)
key(25)=VMM_KEY(wta)
key(26)=VMM_KEY(muta)
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(uta)
err = VMM_GET_VAR(vta)
err = VMM_GET_VAR(tta)
err = VMM_GET_VAR(psdta)
err = VMM_GET_VAR(pipta)
err = VMM_GET_VAR(fipta)
err = VMM_GET_VAR(tdta)
err = VMM_GET_VAR(fita)
err = VMM_GET_VAR(qta)
err = VMM_GET_VAR(sta)
err = VMM_GET_VAR(tpta)
if (.not.Schm_hydro_L) then
err = VMM_GET_VAR(nest_w)
err = VMM_GET_VAR(nest_mu)
err = VMM_GET_VAR(wta)
err = VMM_GET_VAR(muta)
endif
*
if (l_north) then
do k=1,G_nk
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
nest_t (i,j,k) = tta (i,j,k)
nest_psd(i,j,k) = psdta(i,j,k)
nest_pip(i,j,k) = pipta(i,j,k)
nest_fip(i,j,k) = fipta(i,j,k)
nest_td (i,j,k) = tdta (i,j,k)
nest_fi (i,j,k) = fita (i,j,k)
nest_q (i,j,k) = qta (i,j,k)
nest_tp (i,j,k) = tpta (i,j,k)
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_niu
nest_u(i,j,k) = uta(i,j,k)
end do
end do
do j=l_nj-pil_n,l_njv
do i=1,l_ni
nest_v(i,j,k) = vta(i,j,k)
end do
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
nest_s(i,j) = sta(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
nest_w (i,j,k) = wta (i,j,k)
nest_mu(i,j,k) = muta(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
nest_t (i,j,k) = tta (i,j,k)
nest_psd(i,j,k) = psdta(i,j,k)
nest_pip(i,j,k) = pipta(i,j,k)
nest_fip(i,j,k) = fipta(i,j,k)
nest_td (i,j,k) = tdta (i,j,k)
nest_fi (i,j,k) = fita (i,j,k)
nest_q (i,j,k) = qta (i,j,k)
nest_tp (i,j,k) = tpta (i,j,k)
end do
end do
do j=1,l_nj
do i=l_ni-pil_e,l_niu
nest_u(i,j,k) = uta(i,j,k)
end do
end do
do j=1,l_njv
do i=l_ni-pil_e+1,l_ni
nest_v(i,j,k) = vta(i,j,k)
end do
end do
end do
do j=1,l_nj
do i=l_ni-pil_e+1,l_ni
nest_s(i,j) = sta(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
nest_w (i,j,k) = wta (i,j,k)
nest_mu(i,j,k) = muta(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
nest_v (i,j,k) = vta (i,j,k)
nest_t (i,j,k) = tta (i,j,k)
nest_psd(i,j,k) = psdta(i,j,k)
nest_pip(i,j,k) = pipta(i,j,k)
nest_fip(i,j,k) = fipta(i,j,k)
nest_td (i,j,k) = tdta (i,j,k)
nest_fi (i,j,k) = fita (i,j,k)
nest_q (i,j,k) = qta (i,j,k)
nest_tp (i,j,k) = tpta (i,j,k)
end do
end do
do j=1,pil_s
do i=1,l_niu
nest_u(i,j,k) = uta(i,j,k)
end do
end do
end do
do j=1,pil_s
do i=1,l_ni
nest_s(i,j) = sta(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
nest_w (i,j,k) = wta (i,j,k)
nest_mu(i,j,k) = muta(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
nest_u (i,j,k) = uta (i,j,k)
nest_t (i,j,k) = tta (i,j,k)
nest_psd(i,j,k) = psdta(i,j,k)
nest_pip(i,j,k) = pipta(i,j,k)
nest_fip(i,j,k) = fipta(i,j,k)
nest_td (i,j,k) = tdta (i,j,k)
nest_fi (i,j,k) = fita (i,j,k)
nest_q (i,j,k) = qta (i,j,k)
nest_tp (i,j,k) = tpta (i,j,k)
end do
end do
do j=1,l_njv
do i=1,pil_w
nest_v(i,j,k) = vta(i,j,k)
end do
end do
end do
do j=1,l_nj
do i=1,pil_w
nest_s(i,j) = sta(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
nest_w (i,j,k) = wta (i,j,k)
nest_mu(i,j,k) = muta(i,j,k)
end do
end do
end do
endif
endif
*
err = vmmuld(-1,0)
*
key1_ = VMM_KEY (nest_tr)
keya_ = VMM_KEY (trta)
do n=1,Tr3d_ntr
key1(n) = key1_ + n
keya(n) = keya_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1,Tr3d_ntr)
err = vmmlod(keya,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1(n),patr1,tr1)
err = vmmget(keya(n),patra,tra)
if (l_north) then
do k=1,G_nk
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
tr1(i,j,k) = tra(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
tr1(i,j,k) = tra(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
tr1(i,j,k) = tra(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
tr1(i,j,k) = tra(i,j,k)
enddo
enddo
enddo
endif
enddo
err = vmmuld(key1,Tr3d_ntr)
err = vmmuld(keya,Tr3d_ntr)
endif
*
endif
* ---------------------------------------------------------------
return
end