!-------------------------------------- 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_tr - Equivalent to adw_main for TRAJECTORY
*
#include "model_macros_f.h"
*
subroutine adw_main_tr ( F_it ) 1,2
*
#include "impnone.cdk"
*
integer F_it
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_20 - Tanguay M. - Option of storing instead of redoing TRAJ
* v3_21 - Tanguay M. - Revision Openmp
* v3_31 - Tanguay M. - Introduce time extrapolation
* v3_31 - Tanguay M. - SETTLS option
*
*language
* fortran 77
*
*object
* see id section
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------|-------------------------------------------------------|-----|
* F_it | total number of iterations for trajectories | i |
*________|_______________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "adw.cdk"
#include "orhm.cdk"
#include "rhscm.cdk"
#include "vthm.cdk"
#include "vt1m.cdk"
#include "vt0m.cdk"
#include "tr3d.cdk"
#include "offc.cdk"
#include "cstv.cdk"
#include "orh.cdk"
#include "schm.cdk"
#include "v4dr.cdk"
*
************************************************************************
integer vmmlod, vmmget, vmmuld, vmmuln
external vmmlod, vmmget, vmmuld, vmmuln
*
integer pnerr, pnlkey1(30), pnlod, key1m(Tr3d_ntr), key0m(Tr3d_ntr), keyorm(Tr3d_ntr),
$ key1m_, key0m_, keyorm_, err
*
integer nijkag,n,i,j,k
real , dimension (Adw_nit*Adw_njt*l_nk) :: um,vm,wm
*
real wuthm(LDIST_SHAPE,l_nk),wvthm(LDIST_SHAPE,l_nk)
*
real wxthm (l_ni*l_nj*l_nk),wythm (l_ni*l_nj*l_nk)
real wzthm (l_ni*l_nj*l_nk)
real wxcthm(l_ni*l_nj*l_nk),wycthm(l_ni*l_nj*l_nk)
real wzcthm(l_ni*l_nj*l_nk)
*
real*8 aaa_8
real trm,tr0m,orm
pointer (patrm, trm(LDIST_SHAPE,*)),(patr0m, tr0m(LDIST_SHAPE,*))
pointer (paorm, orm(LDIST_SHAPE,*))
*
************************************************************************
if (V4dr_redotr_L) call gem_stop ('ADW_MAIN_TR: REDOTR not done',-1)
************************************************************************
*
if (Lun_debug_L) write (Lun_out,1000)
*
* ---------------------------------------------------------------
* Store in ORTR for ADW_MAIN_3_INT_AD when Orh_icn .eq. Schm_itcn
* ---------------------------------------------------------------
if ( Orh_icn .eq. Schm_itcn. or. .not.Orh_crank_L ) then
*
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)
*
!$omp parallel do
do k=1,l_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
*
do j=1,l_nj
do i=1,l_ni
orm(i,j,k) = tr0m(i,j,k)
end do
end do
*
end do
!$omp end parallel do
*
end do
err = vmmuld(key1m, Tr3d_ntr)
err = vmmuld(key0m, Tr3d_ntr)
err = vmmuld(keyorm,Tr3d_ntr)
endif
*
endif
*
* -----------------------------
* Recover TRAJ RHS interpolated
* -----------------------------
call v4d_rwtraj (8)
*
* ------------------------------
* Preserve or Reset TRAJ (START)
* ------------------------------
pnlkey1(1) = VMM_KEY(ruw2m )
pnlkey1(2) = VMM_KEY(rvw2m )
pnlkey1(3) = VMM_KEY(oruw2m)
pnlkey1(4) = VMM_KEY(orvw2m)
pnlod = 4
*
pnerr = vmmlod(pnlkey1,pnlod)
*
pnerr = VMM_GET_VAR(ruw2m )
pnerr = VMM_GET_VAR(rvw2m )
pnerr = VMM_GET_VAR(oruw2m)
pnerr = VMM_GET_VAR(orvw2m)
*
* --------------------------
* Preserve in ORH for PRE_AD
* --------------------------
!$omp parallel do
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
oruw2m(i,j,k) = ruw2m(i,j,k)
orvw2m(i,j,k) = rvw2m(i,j,k)
end do
end do
end do
!$omp end parallel do
*
pnerr = vmmuld(-1,0)
*
***********************************************************************
*
1000 format(3X,'TRAJ of ADVECT THE RIGHT-HAND-SIDES: (S/R ADW_MAIN_TR)')
*
return
end