!-------------------------------------- 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 adw_main_3_int_tr - Equivalent to adw_main_3_int for TRAJECTORY
*
#include "model_macros_f.h"
*
subroutine adw_main_3_int_tr ( F_um, F_vm, F_wm ),10
*
implicit none
real F_um(*), F_vm(*), F_wm(*)
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_02 - Tanguay M. - restore tracers monotone if V4dg_conf.ne.0
* v3_03 - Tanguay M. - Adjoint NoHyd configuration
* v3_11 - Gravel S. - introduce key Adw_mono_L
* v3_20 - Tanguay M. - Lagrange 3D
* v3_30 - Tanguay M. - Adapt TL/AD to Adw_interp_type_S
* v3_31 - Tanguay M. - Introduce time extrapolation
* v3_31 - Tanguay M. - new scope for operator + adw_cliptraj (LAM)
*
*language
* fortran 77
*
*object
* see id section
*
*TRAJECTORY of
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------|-------------------------------------------------------|-----|
* | | |
* | | |
* F_u,F_v| 3 components of upstream positions at t1 at input | iw |
* F_w | used as work field afterward | |
*________|_______________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "ptopo.cdk"
#include "geomg.cdk"
#include "orh.cdk"
#include "lun.cdk"
#include "schm.cdk"
#include "offc.cdk"
#include "cstv.cdk"
#include "rhscm.cdk"
#include "v4dg.cdk"
#include "adw.cdk"
#include "adwm.cdk"
cvl#include "tr2d.cdk"
#include "tr3d.cdk"
#include "vt1m.cdk"
#include "vt0m.cdk"
#include "orhm.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
************************************************************************
integer i0,in,j0,jn
integer pnerr, pnlkey1(30), key1m(Tr3d_ntr), key0m(Tr3d_ntr), keyorm(Tr3d_ntr),
$ key1m_, key0m_, keyorm_, pnlod, err, dim
*
integer n, nij, nijk, nijkag, cnt, unf, i,j,k
*
real*8 aaa_8
real trm,tr0m,orm
pointer (patrm, trm(LDIST_SHAPE,*)),(patr0m, tr0m(LDIST_SHAPE,*))
pointer (paorm, orm(LDIST_SHAPE,*))
* __________________________________________________________
*
if ( Adw_interp_type_S(1:5).ne.'LAG3D' )
$ call gem_stop ('ADW_MAIN_3_INT_TR: Adw_interp_type_S(1:5).ne.LAG3D not done',-1)
*
cvl if ( Tr2d_ntr.ne.0 ) call gem_stop('adw_main_3_int_tr',-1)
* __________________________________________________________
*
if (Lun_debug_L) write (Lun_out,1000)
nij = l_ni *l_nj
nijk = l_ni *l_nj *l_nk
nijkag = Adw_nit*Adw_njt*l_nk
call hpalloc(Adwm_capx1m_ ,nijk, err,1)
call hpalloc(Adwm_capy1m_ ,nijk, err,1)
call hpalloc(Adwm_capz1m_ ,nijk, err,1)
call hpalloc(Adwm_n1m_ ,nijk, err,1)
call hpalloc(Adwm_xdd1m_ ,nijk, err,1)
call hpalloc(Adwm_xgg1m_ ,nijk, err,1)
call hpalloc(Adwm_ydd1m_ ,nijk, err,1)
call hpalloc(Adwm_ygg1m_ ,nijk, err,1)
call hpalloc(Adwm_cz1m_ ,nijk, err,1)
call hpalloc(Adwm_c1m_ ,nijk, err,1)
call hpalloc(Adwm_wrkbm_ ,nijk, err,1)
call hpalloc(Adwm_wrkcm_ ,nijk, err,1)
*
************************************************************************
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_west) i0=pil_w
if (l_east) in=l_niu - pil_e + 2
if (l_south) j0=pil_s
if (l_north) jn=l_njv - pil_n + 2
call adw_cliptraj ( F_um, F_vm, i0, in, j0, jn, 'INTERP')
endif
*
if( .not. Adw_interp_type_S(1:5).eq.'LAG3D' ) then
call adw_setint ( Adwm_n1m,Adwm_capx1m,Adwm_xgg1m,Adwm_xdd1m,Adwm_capy1m,Adwm_ygg1m,
% Adwm_ydd1m, Adwm_capz1m, Adwm_cz1m, F_um, F_vm, F_wm,
% .true., .true., .false., nijk,i0,in,j0,jn,l_nk)
else
* ----------------------------
* Keep positions in CAP fields
* ----------------------------
!$omp parallel do private(n)
do k=1,l_nk
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
Adwm_capx1m(n) = F_um(n)
Adwm_capy1m(n) = F_vm(n)
Adwm_capz1m(n) = F_wm(n)
end do
end do
end do
!$omp end parallel do
endif
*
***********************************************************************
* Perform interpolation
***********************************************************************
pnlkey1(1) = VMM_KEY(ruw1m)
pnlkey1(2) = VMM_KEY(rvw1m)
pnlkey1(3) = VMM_KEY(ruw2m)
pnlkey1(4) = VMM_KEY(rvw2m)
pnlkey1(5) = VMM_KEY(rcnm)
pnlkey1(6) = VMM_KEY(rthm)
pnlod = 6
*
if (.not. Schm_hydro_L) then
pnlkey1(7) = VMM_KEY(rwm)
pnlkey1(8) = VMM_KEY(rvvm)
pnlod = 8
endif
*
pnerr = vmmlod(pnlkey1,pnlod)
*
pnerr = VMM_GET_VAR(ruw1m)
pnerr = VMM_GET_VAR(rvw1m)
pnerr = VMM_GET_VAR(ruw2m)
pnerr = VMM_GET_VAR(rvw2m)
pnerr = VMM_GET_VAR(rcnm)
pnerr = VMM_GET_VAR(rthm)
*
if (.not. Schm_hydro_L) then
pnerr = VMM_GET_VAR(rwm)
pnerr = VMM_GET_VAR(rvvm)
endif
*
call adw_interp_tr (ruw2m, ruw1m, F_um, F_vm,
% .true., .false., LDIST_DIM, l_nk,i0,in,j0,jn)
*
call adw_interp_tr (rvw2m, rvw1m, F_um, F_vm,
% .true., .false., LDIST_DIM, l_nk,i0,in,j0,jn)
*
call adw_interp_tr (rcnm, rcnm, F_um, F_vm,
% .false., .false., LDIST_DIM, l_nk,i0,in,j0,jn)
*
call adw_interp_tr (rthm, rthm, F_um, F_vm,
% .false., .false., LDIST_DIM, l_nk,i0,in,j0,jn)
*
if (.not. Schm_hydro_L) then
call adw_interp_tr (rwm, rwm, F_um, F_vm,
% .false., .false., LDIST_DIM, l_nk,i0,in,j0,jn)
*
call adw_interp_tr (rvvm, rvvm, F_um, F_vm,
% .false., .false., LDIST_DIM, l_nk,i0,in,j0,jn)
endif
*
if ( Orh_icn .eq. Schm_itcn. or. .not.Orh_crank_L ) then
*
* tr3d advection
*
aaa_8 = ( Offc_a1_8 / Offc_b0_8 )/ Cstv_dt_8
*
key1m_ = VMM_KEY (trt1m)
key0m_ = VMM_KEY (trt0m)
keyorm_= VMM_KEY (ortrm)
do n=1,Tr3d_ntr
key1m (n) = key1m_ + n
key0m (n) = key0m_ + n
keyorm(n) = keyorm_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1m, Tr3d_ntr)
err = vmmlod(key0m, Tr3d_ntr)
err = vmmlod(keyorm,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1m (n),patrm, trm)
err = vmmget(key0m (n),patr0m,tr0m)
err = vmmget(keyorm(n),paorm, orm)
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
tr0m(i,j,k) = - aaa_8*trm(i,j,k)
end do
end do
end do
* ---------------------------------------------------------------
* Store in ORTR for ADW_MAIN_3_INT_AD when Orh_icn .eq. Schm_itcn
* ---------------------------------------------------------------
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
orm(i,j,k) = tr0m(i,j,k)
end do
end do
end do
call adw_interp_tr ( tr0m, tr0m, F_um, F_vm,
% .false., Adw_mono_L, LDIST_DIM, l_nk,i0,in,j0,jn)
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
tr0m(i,j,k) = Cstv_tau_8*tr0m(i,j,k)
end do
end do
end do
end do
err = vmmuld(key1m, Tr3d_ntr)
err = vmmuld(key0m, Tr3d_ntr)
err = vmmuld(keyorm,Tr3d_ntr)
endif
*
endif
*
***********************************************************************
* Deallocate
***********************************************************************
call hpdeallc(Adwm_capx1m_ ,err,1)
call hpdeallc(Adwm_capy1m_ ,err,1)
call hpdeallc(Adwm_capz1m_ ,err,1)
call hpdeallc(Adwm_n1m_ ,err,1)
call hpdeallc(Adwm_xdd1m_ ,err,1)
call hpdeallc(Adwm_xgg1m_ ,err,1)
call hpdeallc(Adwm_ydd1m_ ,err,1)
call hpdeallc(Adwm_ygg1m_ ,err,1)
call hpdeallc(Adwm_cz1m_ ,err,1)
call hpdeallc(Adwm_c1m_ ,err,1)
call hpdeallc(Adwm_wrkbm_ ,err,1)
call hpdeallc(Adwm_wrkcm_ ,err,1)
*
pnerr = vmmuld(-1,0)
*
1000 format(3X,'TRAJ of ADVECT THE RIGHT-HAND-SIDES: (S/R ADW_MAIN_3_INT_TR)')
*
return
end