!-------------------------------------- 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 digflt_tl - TLM of digflt
*
#include "model_macros_f.h"
*
subroutine digflt_tl 2,1
*
implicit none
*
*author
* M Tanguay - rpn - july 2003
*
*revision
* v3_11 - Tanguay M. - initial MPI version
* v3_21 - Lee V. - Remove TR2d
* v3_30 - Tanguay M. - Adapt TL/AD to itf
*
*object
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "mem.cdk"
#include "init.cdk"
#include "lctl.cdk"
#include "lun.cdk"
#include "rstr.cdk"
#include "schm.cdk"
#include "vta.cdk"
#include "vt1.cdk"
#include "vtx.cdk"
#include "vtam.cdk"
#include "vt1m.cdk"
#include "vtxm.cdk"
cvl#include "tr2d.cdk"
#include "tr3d.cdk"
#include "itf_phy_buses.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
integer open_db_file,close_db_file,rewind_db_file,
$ read_db_file,write_db_file
external open_db_file,close_db_file,rewind_db_file,
$ read_db_file,write_db_file
*
integer err, key(52), i, j, k, n, key1_, keya_, key1(Tr3d_ntr),
$ keya(Tr3d_ntr), pnlod,
$ key1m_, keyam_, key1m(Tr3d_ntr), keyam(Tr3d_ntr)
real tr1,tra,tr1m,tram
pointer (patr1, tr1 (LDIST_SHAPE,*)),(patra, tra (LDIST_SHAPE,*))
pointer (patr1m, tr1m(LDIST_SHAPE,*)),(patram, tram(LDIST_SHAPE,*))
real busper(max(1,p_bper_siz)), dfcoef
* __________________________________________________________________
*
call gem_stop ('VERIFY digflt_tl',-1)
*
cvl if ( Tr2d_ntr.ne.0 ) call gem_stop ('digflt_tl',-1)
*
dfcoef = Init_dfco( abs( (Init_dfnp-1)/2 - Lctl_step ) )
*
***************************************************************
* Hydrostatic model fields
***************************************************************
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 )
pnlod = 26
* TRAJECTORY
* ----------
key(pnlod+1) = VMM_KEY(utam )
key(pnlod+2) = VMM_KEY(ut1m )
key(pnlod+3) = VMM_KEY(vtam )
key(pnlod+4) = VMM_KEY(vt1m )
key(pnlod+5) = VMM_KEY(tdtam )
key(pnlod+6) = VMM_KEY(tdt1m )
key(pnlod+7) = VMM_KEY(fitam )
key(pnlod+8) = VMM_KEY(fit1m )
key(pnlod+9) = VMM_KEY(fiptam)
key(pnlod+10) = VMM_KEY(fipt1m)
key(pnlod+11) = VMM_KEY(ttam )
key(pnlod+12) = VMM_KEY(tt1m )
key(pnlod+13) = VMM_KEY(qtam )
key(pnlod+14) = VMM_KEY(qt1m )
key(pnlod+15) = VMM_KEY(tptam )
key(pnlod+16) = VMM_KEY(tpt1m )
key(pnlod+17) = VMM_KEY(piptam)
key(pnlod+18) = VMM_KEY(pipt1m)
key(pnlod+19) = VMM_KEY(tpltam)
key(pnlod+20) = VMM_KEY(tplt1m)
key(pnlod+21) = VMM_KEY(psdtam)
key(pnlod+22) = VMM_KEY(psdt1m)
key(pnlod+23) = VMM_KEY(stam )
key(pnlod+24) = VMM_KEY(st1m )
key(pnlod+25) = VMM_KEY(gptam )
key(pnlod+26) = VMM_KEY(gptxm )
pnlod = pnlod+26
*
err = vmmlod(key,pnlod)
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 )
* TRAJECTORY
* ----------
err = VMM_GET_VAR(utam )
err = VMM_GET_VAR(ut1m )
err = VMM_GET_VAR(vtam )
err = VMM_GET_VAR(vt1m )
err = VMM_GET_VAR(tdtam )
err = VMM_GET_VAR(tdt1m )
err = VMM_GET_VAR(fitam )
err = VMM_GET_VAR(fit1m )
err = VMM_GET_VAR(fiptam)
err = VMM_GET_VAR(fipt1m)
err = VMM_GET_VAR(ttam )
err = VMM_GET_VAR(tt1m )
err = VMM_GET_VAR(qtam )
err = VMM_GET_VAR(qt1m )
err = VMM_GET_VAR(tptam )
err = VMM_GET_VAR(tpt1m )
err = VMM_GET_VAR(piptam)
err = VMM_GET_VAR(pipt1m)
err = VMM_GET_VAR(tpltam)
err = VMM_GET_VAR(tplt1m)
err = VMM_GET_VAR(psdtam)
err = VMM_GET_VAR(psdt1m)
err = VMM_GET_VAR(stam )
err = VMM_GET_VAR(st1m )
err = VMM_GET_VAR(gptam )
err = VMM_GET_VAR(gptxm )
*
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
*
* TRAJECTORY
* ----------
utam(i,j,k) = utam(i,j,k) + dfcoef * ut1m(i,j,k)
vtam(i,j,k) = vtam(i,j,k) + dfcoef * vt1m(i,j,k)
tdtam(i,j,k) = tdtam(i,j,k) + dfcoef * tdt1m(i,j,k)
fitam(i,j,k) = fitam(i,j,k) + dfcoef * fit1m(i,j,k)
fiptam(i,j,k) = fiptam(i,j,k) + dfcoef * fipt1m(i,j,k)
ttam(i,j,k) = ttam(i,j,k) + dfcoef * tt1m(i,j,k)
qtam(i,j,k) = qtam(i,j,k) + dfcoef * qt1m(i,j,k)
tptam(i,j,k) = tptam(i,j,k) + dfcoef * tpt1m(i,j,k)
piptam(i,j,k) = piptam(i,j,k) + dfcoef * pipt1m(i,j,k)
tpltam(i,j,k) = tpltam(i,j,k) + dfcoef * tplt1m(i,j,k)
psdtam(i,j,k) = psdtam(i,j,k) + dfcoef * psdt1m(i,j,k)
gptam(i,j,k) = gptam(i,j,k) + dfcoef * gptxm(i,j,k)
* TLM
* ---
uta(i,j,k) = uta(i,j,k) + dfcoef * ut1(i,j,k)
vta(i,j,k) = vta(i,j,k) + dfcoef * vt1(i,j,k)
tdta(i,j,k) = tdta(i,j,k) + dfcoef * tdt1(i,j,k)
fita(i,j,k) = fita(i,j,k) + dfcoef * fit1(i,j,k)
fipta(i,j,k) = fipta(i,j,k) + dfcoef * fipt1(i,j,k)
tta(i,j,k) = tta(i,j,k) + dfcoef * tt1(i,j,k)
qta(i,j,k) = qta(i,j,k) + dfcoef * qt1(i,j,k)
tpta(i,j,k) = tpta(i,j,k) + dfcoef * tpt1(i,j,k)
pipta(i,j,k) = pipta(i,j,k) + dfcoef * pipt1(i,j,k)
tplta(i,j,k) = tplta(i,j,k) + dfcoef * tplt1(i,j,k)
psdta(i,j,k) = psdta(i,j,k) + dfcoef * psdt1(i,j,k)
gpta(i,j,k) = gpta(i,j,k) + dfcoef * gptx(i,j,k)
*
end do
end do
end do
*
do j= 1, l_nj
do i= 1, l_ni
*
* TRAJECTORY
* ----------
stam(i,j) = stam(i,j) + dfcoef * st1m(i,j)
*
* TLM
* ---
sta(i,j) = sta(i,j) + dfcoef * st1(i,j)
*
end do
end do
*
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 )
pnlod = 8
*
key(pnlod+1) = VMM_KEY(wtam )
key(pnlod+2) = VMM_KEY(wt1m )
key(pnlod+3) = VMM_KEY(qptam )
key(pnlod+4) = VMM_KEY(qpt1m )
key(pnlod+5) = VMM_KEY(multam)
key(pnlod+6) = VMM_KEY(multxm)
key(pnlod+7) = VMM_KEY(mutam )
key(pnlod+8) = VMM_KEY(mut1m )
pnlod = pnlod + 8
*
err = vmmlod(key,pnlod)
*
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 )
*
* TRAJECTORY
* ----------
err = VMM_GET_VAR(wtam )
err = VMM_GET_VAR(wt1m )
err = VMM_GET_VAR(qptam )
err = VMM_GET_VAR(qpt1m )
err = VMM_GET_VAR(multam)
err = VMM_GET_VAR(multxm)
err = VMM_GET_VAR(mutam )
err = VMM_GET_VAR(mut1m )
*
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
*
* TRAJECTORY
* ----------
wtam(i,j,k) = wtam(i,j,k) + dfcoef * wt1m(i,j,k)
qptam(i,j,k) = qptam(i,j,k) + dfcoef * qpt1m(i,j,k)
multam(i,j,k) = multam(i,j,k) + dfcoef * multxm(i,j,k)
mutam(i,j,k) = mutam(i,j,k) + dfcoef * mut1m(i,j,k)
*
* TLM
* ---
wta(i,j,k) = wta(i,j,k) + dfcoef * wt1(i,j,k)
qpta(i,j,k) = qpta(i,j,k) + dfcoef * qpt1(i,j,k)
multa(i,j,k) = multa(i,j,k) + dfcoef * multx(i,j,k)
muta(i,j,k) = muta(i,j,k) + dfcoef * mut1(i,j,k)
*
end do
end do
end do
*
err = vmmuld(-1,0)
*
endif
****************************************************************
* Passive tracers (no passive tracers in linear model)
****************************************************************
if ( Init_dftr_L ) then
*
key1m_ = VMM_KEY (trt1m)
keyam_ = VMM_KEY (trtam)
key1_ = VMM_KEY (trt1)
keya_ = VMM_KEY (trta)
do n=1,Tr3d_ntr
key1m(n) = key1m_ + n
keyam(n) = keyam_ + n
*
key1(n) = key1_ + n
keya(n) = keya_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1m,Tr3d_ntr)
err = vmmlod(keyam,Tr3d_ntr)
err = vmmlod(key1, Tr3d_ntr)
err = vmmlod(keya, Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1m(n),patr1m,tr1m)
err = vmmget(keyam(n),patram,tram)
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
tram(i,j,k) = tram(i,j,k) + dfcoef * tr1m(i,j,k)
tra (i,j,k) = tra (i,j,k) + dfcoef * tr1 (i,j,k)
end do
end do
end do
end do
err = vmmuld(key1m,Tr3d_ntr)
err = vmmuld(keyam,Tr3d_ntr)
err = vmmuld(key1, Tr3d_ntr)
err = vmmuld(keya, Tr3d_ntr)
endif
*
elseif ( Lctl_step .eq. (Init_dfnp-1)/2 ) then
*
key1m_ = VMM_KEY (trt1m)
keyam_ = VMM_KEY (trtam)
key1_ = VMM_KEY (trt1)
keya_ = VMM_KEY (trta)
do n=1,Tr3d_ntr
key1m(n) = key1m_ + n
keyam(n) = keyam_ + n
key1 (n) = key1_ + n
keya (n) = keya_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1m,Tr3d_ntr)
err = vmmlod(keyam,Tr3d_ntr)
err = vmmlod(key1, Tr3d_ntr)
err = vmmlod(keya, Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1m(n),patr1m,tr1m)
err = vmmget(keyam(n),patram,tram)
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
*
* TRAJECTORY
* ----------
tram(i,j,k) = tr1m(i,j,k)
*
* TLM
* ---
tra(i,j,k) = tr1(i,j,k)
*
end do
end do
end do
end do
err = vmmuld(key1m,Tr3d_ntr)
err = vmmuld(keyam,Tr3d_ntr)
err = vmmuld(key1, Tr3d_ntr)
err = vmmuld(keya, Tr3d_ntr)
endif
*
endif
***********************************************************************
* Physics fields at half span are saved to be used after initialisation
***********************************************************************
*
* --------------------------------------------------------------------------------
* NOTE: For TLM of simplified physics, the requested TRAJECTORY is given in RWTRAJ
* --------------------------------------------------------------------------------
if (.FALSE.) then
if ( Lctl_step .eq. (Init_dfnp-1)/2 .and. Schm_phyms_L ) then
if ( .not. associated ( Phy_busper3D_digf ) )
$ allocate ( Phy_busper3D_digf (p_bper_siz*p_nj))
Phy_busper3D_digf = Phy_busper3D
endif
endif
*
Rstri_half_L = .false.
if (Lctl_step.ge.(Init_dfnp-1)/2) Rstri_half_L = .true.
*
return
end