!-------------------------------------- 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_init -- Initializes nesting data for LAM configuration
*
#include "model_macros_f.h"
*
subroutine nest_init () 1,14
implicit none
*
integer nesd
*
*author M. Desgagne - April 2002
*
*revision
* v3_00 - Desgagne M. - initial version
* v3_03 - Tanguay M. - Adjoint Lam configuration
* v3_30 - Tanguay M. - adapt to bcs
* v3_31 - Lee V. - add 3DF pilot for Schm_offline_L
*
*implicits
#include "glb_ld.cdk"
#include "bcsdim.cdk"
#include "bcsmem.cdk"
#include "vt1.cdk"
#include "tr3d.cdk"
#include "nest.cdk"
#include "schm.cdk"
#include "v4dg.cdk"
#include "lun.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
real tr1,trf
pointer (patr1, tr1(LDIST_SHAPE,*)), (patrf, trf(LDIST_SHAPE,*))
integer i,j,k,err,pnlkey1(26),nvar,key1(Tr3d_ntr),key1_,
$ key2(Tr3d_ntr),key2_,n,id
integer*8 pnt_tr1(Tr3d_ntr),pnt_trf(Tr3d_ntr)
*
logical done_init_L
data done_init_L /.false./
save done_init_L
* ---------------------------------------------------------------
*
* -------------------------------------------------------
* When Regular forward GEM, done_init_L = .F.
* When 4D-Var, done_init_L = .T. if not first forward run
* -------------------------------------------------------
*
if (V4dg_conf.ne.0 .and. V4dg_part.ne.3) return
if ( .not.done_init_L ) then
*
if (Lun_debug_L) write(Lun_out,1000)
pnlkey1(1) = VMM_KEY(ut1)
pnlkey1(2) = VMM_KEY(vt1)
pnlkey1(3) = VMM_KEY(qt1)
pnlkey1(4) = VMM_KEY(tt1)
pnlkey1(5) = VMM_KEY(fit1)
pnlkey1(6) = VMM_KEY(tdt1)
pnlkey1(7) = VMM_KEY(psdt1)
pnlkey1(8) = VMM_KEY(pipt1)
pnlkey1(9) = VMM_KEY(fipt1)
pnlkey1(10) = VMM_KEY(st1)
pnlkey1(11) = VMM_KEY(tpt1)
pnlkey1(12) = VMM_KEY(nest_u)
pnlkey1(13) = VMM_KEY(nest_v)
pnlkey1(14) = VMM_KEY(nest_t)
pnlkey1(15) = VMM_KEY(nest_psd)
pnlkey1(16) = VMM_KEY(nest_pip)
pnlkey1(17) = VMM_KEY(nest_fip)
pnlkey1(18) = VMM_KEY(nest_td)
pnlkey1(19) = VMM_KEY(nest_fi)
pnlkey1(20) = VMM_KEY(nest_q)
pnlkey1(21) = VMM_KEY(nest_s)
pnlkey1(22) = VMM_KEY(nest_tp)
nvar = 22
*
if (.not. Schm_hydro_L) then
pnlkey1(23) = VMM_KEY(wt1)
pnlkey1(24) = VMM_KEY(mut1)
pnlkey1(25) = VMM_KEY(nest_w)
pnlkey1(26) = VMM_KEY(nest_mu)
nvar = 26
endif
*
err = vmmlod(pnlkey1,nvar)
err = VMM_GET_VAR(ut1)
err = VMM_GET_VAR(vt1)
err = VMM_GET_VAR(qt1)
err = VMM_GET_VAR(tt1)
err = VMM_GET_VAR(fit1)
err = VMM_GET_VAR(tdt1)
err = VMM_GET_VAR(psdt1)
err = VMM_GET_VAR(pipt1)
err = VMM_GET_VAR(fipt1)
err = VMM_GET_VAR(st1)
err = VMM_GET_VAR(tpt1)
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)
if (.not. Schm_hydro_L) then
err = VMM_GET_VAR(wt1)
err = VMM_GET_VAR(mut1)
err = VMM_GET_VAR(nest_mu)
err = VMM_GET_VAR(nest_w)
endif
*
key1_ = VMM_KEY (trt1)
key2_ = VMM_KEY (nest_tr)
do n=1,Tr3d_ntr
key1(n) = key1_ + n
key2(n) = key2_ + n
end do
err = vmmlod(key1,Tr3d_ntr)
err = vmmlod(key2,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1(n),patr1,tr1)
err = vmmget(key2(n),patrf,trf)
pnt_tr1(n) = patr1
pnt_trf(n) = patrf
end do
*
* copying values from UT1 to BCS_U boundary condition boxes
*
call trnes (ut1,bcs_u(bcs_is),bcs_u(bcs_in),bcs_u(bcs_iw),
$ bcs_u(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (vt1,bcs_v(bcs_is),bcs_v(bcs_in),bcs_v(bcs_iw),
$ bcs_v(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (tt1,bcs_t(bcs_is),bcs_t(bcs_in),bcs_t(bcs_iw),
$ bcs_t(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (psdt1,bcs_psd(bcs_is),bcs_psd(bcs_in),bcs_psd(bcs_iw),
$ bcs_psd(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (pipt1,bcs_pip(bcs_is),bcs_pip(bcs_in),bcs_pip(bcs_iw),
$ bcs_pip(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (fipt1,bcs_fip(bcs_is),bcs_fip(bcs_in),bcs_fip(bcs_iw),
$ bcs_fip(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (tdt1,bcs_td(bcs_is),bcs_td(bcs_in),bcs_td(bcs_iw),
$ bcs_td(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (fit1,bcs_fi(bcs_is),bcs_fi(bcs_in),bcs_fi(bcs_iw),
$ bcs_fi(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (qt1,bcs_q(bcs_is),bcs_q(bcs_in),bcs_q(bcs_iw),
$ bcs_q(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (st1,bcs_s(bcs_is),bcs_s(bcs_in),bcs_s(bcs_iw),
$ bcs_s(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,1,0)
call trnes (tpt1,bcs_tp(bcs_is),bcs_tp(bcs_in),bcs_tp(bcs_iw),
$ bcs_tp(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
*
if (.not. Schm_hydro_L) then
call trnes (wt1,bcs_w(bcs_is),bcs_w(bcs_in),bcs_w(bcs_iw),
$ bcs_w(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
call trnes (mut1,bcs_mu(bcs_is),bcs_mu(bcs_in),bcs_mu(bcs_iw),
$ bcs_mu(bcs_ie),l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
endif
*
do n=1,Tr3d_ntr
id = (n-1)*bcs_sz+1
patr1 = pnt_tr1(n)
call trnes (tr1,bcs_tr(id),bcs_tr(id+bcs_in-1),
$ bcs_tr(id+bcs_iw-1),bcs_tr(id+bcs_ie-1),
$ l_minx,l_maxx,l_miny,l_maxy,minxs,maxxs,
$ minys,maxys,minxw,maxxw,minyw,maxyw,G_nk,0)
end do
*
* copying values from UT1 to nest_u variables
*
do k= 1, G_nk
do j= 1, l_nj
do i= 1, l_ni
nest_u (i,j,k) = ut1 (i,j,k)
nest_v (i,j,k) = vt1 (i,j,k)
nest_t (i,j,k) = tt1 (i,j,k)
nest_psd(i,j,k) = psdt1(i,j,k)
nest_pip(i,j,k) = pipt1(i,j,k)
nest_fip(i,j,k) = fipt1(i,j,k)
nest_td (i,j,k) = tdt1 (i,j,k)
nest_fi (i,j,k) = fit1 (i,j,k)
nest_q (i,j,k) = qt1 (i,j,k)
nest_tp (i,j,k) = tpt1 (i,j,k)
end do
end do
end do
do j= 1, l_nj
do i= 1, l_ni
nest_s(i,j) = st1(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, l_ni
nest_w (i,j,k) = wt1 (i,j,k)
nest_mu (i,j,k) = mut1 (i,j,k)
end do
end do
end do
endif
*
c if (Acid_test_L) then u,fi,t,psd,td,tp,pip,s
c if (Lun_out.gt.0) write(Lun_out,*)'Nest variables'
c call glbstat (nest_u,'u',LDIST_DIM,G_nk,1+acid_i0,G_ni-1-acid_in,
c % 1+acid_j0,G_nj-acid_jn,1,G_nk)
c call glbstat (nest_tp,'tp',LDIST_DIM,G_nk,8+acid_i0,G_ni-7-acid_in,
c % 8+acid_j0,G_nj-7-acid_jn,1,G_nk)
*
err = vmmuld(pnlkey1,nvar)
*
do n=1,Tr3d_ntr
patr1 = pnt_tr1(n)
patrf = pnt_trf(n)
do k= 1, G_nk
do j= 1, l_nj
do i= 1, l_ni
trf (i,j,k) = tr1 (i,j,k)
end do
end do
end do
end do
*
if(V4dg_conf.ne.0) then
*
done_init_L = .true.
*
* DO NOTHING
*
endif
* done_init loop
endif
*
1000 format(3X,'NESTING INITIALIZATION (NEST_INIT)')
* ---------------------------------------------------------------
return
end