!-------------------------------------- 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 rhs_tl - TLM of rhs
*
#include "model_macros_f.h"
*
subroutine rhs_tl() 1,1
*
implicit none
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_21 - Tanguay M. - replace xfis by topo
* v2_31 - Tanguay M. - adapt for tracers in tr3d
* v3_03 - Tanguay M. - Adjoint Lam and NoHyd configuration
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_21 - Tanguay M. - Revision Openmp
*
*object
* see id section
* -------------------------------------------------------------
* REMARK:INPUT TRAJ:F_um,F_vm,F_tm,F_qm,F_fim,F_sm,F_tdm,F_psdm
* F_nestm_um, F_nestm_vm (G_lam)
* -------------------------------------------------------------
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "schm.cdk"
#include "lun.cdk"
#include "orh.cdk"
#include "p_geof.cdk"
#include "rhsc.cdk"
#include "vt1.cdk"
#include "nest.cdk"
#include "orhm.cdk"
#include "rhscm.cdk"
#include "vt1m.cdk"
#include "nestm.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
*
integer pnerr, pnlod, pnlkey1(100), i, j, k
* __________________________________________________________________
*
if(Lun_debug_L) write (Lun_out,1000)
*
pnlkey1( 1) = VMM_KEY(ru)
pnlkey1( 2) = VMM_KEY(rv)
pnlkey1( 3) = VMM_KEY(rcn)
pnlkey1( 4) = VMM_KEY(rth)
pnlkey1( 5) = VMM_KEY(oru)
pnlkey1( 6) = VMM_KEY(orv)
pnlkey1( 7) = VMM_KEY(orcn)
pnlkey1( 8) = VMM_KEY(orth)
pnlkey1( 9) = VMM_KEY(ruw1)
pnlkey1(10) = VMM_KEY(rvw1)
pnlkey1(11) = VMM_KEY(ut1)
pnlkey1(12) = VMM_KEY(vt1)
pnlkey1(13) = VMM_KEY(tt1)
pnlkey1(14) = VMM_KEY(qt1)
pnlkey1(15) = VMM_KEY(fit1)
pnlkey1(16) = VMM_KEY(st1)
pnlkey1(17) = VMM_KEY(tdt1)
pnlkey1(18) = VMM_KEY(psdt1)
pnlod = 18
if (.not. Schm_hydro_L) then
pnlkey1(pnlod+1) = VMM_KEY(rw)
pnlkey1(pnlod+2) = VMM_KEY(rvv)
pnlkey1(pnlod+3) = VMM_KEY(orw)
pnlkey1(pnlod+4) = VMM_KEY(orvv)
pnlkey1(pnlod+5) = VMM_KEY(wt1)
pnlkey1(pnlod+6) = VMM_KEY(topo)
pnlkey1(pnlod+7) = VMM_KEY(fipt1)
pnlkey1(pnlod+8) = VMM_KEY(mut1)
pnlod = pnlod+8
endif
if (G_lam) then
pnlkey1(pnlod+1) = VMM_KEY(nest_u)
pnlkey1(pnlod+2) = VMM_KEY(nest_v)
pnlod = pnlod+2
endif
*
* TRAJECTORY
* ----------
pnlkey1(pnlod + 1) = VMM_KEY(rum)
pnlkey1(pnlod + 2) = VMM_KEY(rvm)
pnlkey1(pnlod + 3) = VMM_KEY(rcnm)
pnlkey1(pnlod + 4) = VMM_KEY(rthm)
pnlkey1(pnlod + 5) = VMM_KEY(orum)
pnlkey1(pnlod + 6) = VMM_KEY(orvm)
pnlkey1(pnlod + 7) = VMM_KEY(orcnm)
pnlkey1(pnlod + 8) = VMM_KEY(orthm)
pnlkey1(pnlod + 9) = VMM_KEY(ruw1m)
pnlkey1(pnlod + 10) = VMM_KEY(rvw1m)
pnlkey1(pnlod + 11) = VMM_KEY(ut1m)
pnlkey1(pnlod + 12) = VMM_KEY(vt1m)
pnlkey1(pnlod + 13) = VMM_KEY(tt1m)
pnlkey1(pnlod + 14) = VMM_KEY(qt1m)
pnlkey1(pnlod + 15) = VMM_KEY(fit1m)
pnlkey1(pnlod + 16) = VMM_KEY(st1m)
pnlkey1(pnlod + 17) = VMM_KEY(tdt1m)
pnlkey1(pnlod + 18) = VMM_KEY(psdt1m)
pnlod = pnlod + 18
if (.not. Schm_hydro_L) then
pnlkey1(pnlod+1) = VMM_KEY(rwm)
pnlkey1(pnlod+2) = VMM_KEY(rvvm)
pnlkey1(pnlod+3) = VMM_KEY(orwm)
pnlkey1(pnlod+4) = VMM_KEY(orvvm)
pnlkey1(pnlod+5) = VMM_KEY(wt1m)
pnlkey1(pnlod+6) = VMM_KEY(fipt1m)
pnlkey1(pnlod+7) = VMM_KEY(mut1m)
pnlod = pnlod+7
endif
if (G_lam) then
pnlkey1(pnlod+1) = VMM_KEY(nestm_um)
pnlkey1(pnlod+2) = VMM_KEY(nestm_vm)
pnlod = pnlod+2
endif
*
* - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,pnlod)
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ru)
pnerr = VMM_GET_VAR(rv)
pnerr = VMM_GET_VAR(rcn)
pnerr = VMM_GET_VAR(rth)
pnerr = VMM_GET_VAR(oru)
pnerr = VMM_GET_VAR(orv)
pnerr = VMM_GET_VAR(orcn)
pnerr = VMM_GET_VAR(orth)
pnerr = VMM_GET_VAR(ruw1)
pnerr = VMM_GET_VAR(rvw1)
pnerr = VMM_GET_VAR(ut1)
pnerr = VMM_GET_VAR(vt1)
pnerr = VMM_GET_VAR(tt1)
pnerr = VMM_GET_VAR(qt1)
pnerr = VMM_GET_VAR(fit1)
pnerr = VMM_GET_VAR(st1)
pnerr = VMM_GET_VAR(tdt1)
pnerr = VMM_GET_VAR(psdt1)
if (.not. Schm_hydro_L) then
pnerr = VMM_GET_VAR(rw)
pnerr = VMM_GET_VAR(rvv)
pnerr = VMM_GET_VAR(orw)
pnerr = VMM_GET_VAR(orvv)
pnerr = VMM_GET_VAR(wt1)
pnerr = VMM_GET_VAR(topo)
pnerr = VMM_GET_VAR(fipt1)
pnerr = VMM_GET_VAR(mut1)
else
rw_ = 0
rvv_ = 0
orw_ = 0
orvv_ = 0
wt1_ = 0
topo_ = 0
fipt1_= 0
mut1_ = 0
endif
if (G_lam) then
pnerr = VMM_GET_VAR(nest_u)
pnerr = VMM_GET_VAR(nest_v)
else
nest_u_ = 0
nest_v_ = 0
endif
*
* TRAJECTORY
* ----------
pnerr = VMM_GET_VAR(rum)
pnerr = VMM_GET_VAR(rvm)
pnerr = VMM_GET_VAR(rcnm)
pnerr = VMM_GET_VAR(rthm)
pnerr = VMM_GET_VAR(orum)
pnerr = VMM_GET_VAR(orvm)
pnerr = VMM_GET_VAR(orcnm)
pnerr = VMM_GET_VAR(orthm)
pnerr = VMM_GET_VAR(ruw1m)
pnerr = VMM_GET_VAR(rvw1m)
pnerr = VMM_GET_VAR(ut1m)
pnerr = VMM_GET_VAR(vt1m)
pnerr = VMM_GET_VAR(tt1m)
pnerr = VMM_GET_VAR(qt1m)
pnerr = VMM_GET_VAR(fit1m)
pnerr = VMM_GET_VAR(st1m)
pnerr = VMM_GET_VAR(tdt1m)
pnerr = VMM_GET_VAR(psdt1m)
*
if (.not. Schm_hydro_L) then
pnerr = VMM_GET_VAR(rwm)
pnerr = VMM_GET_VAR(rvvm)
pnerr = VMM_GET_VAR(orwm)
pnerr = VMM_GET_VAR(orvvm)
pnerr = VMM_GET_VAR(wt1m)
pnerr = VMM_GET_VAR(fipt1m)
pnerr = VMM_GET_VAR(mut1m)
else
rwm_ = 0
rvvm_ = 0
orwm_ = 0
orvvm_ = 0
wt1m_ = 0
fipt1m_= 0
mut1m_ = 0
endif
if (G_lam) then
pnerr = VMM_GET_VAR(nestm_um)
pnerr = VMM_GET_VAR(nestm_vm)
else
nestm_um_ = 0
nestm_vm_ = 0
endif
*
* Perform the computation in the first
* cycle of Crank-Nicholson procedure only
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if ( Orh_icn .eq. 1 ) then
*
call rhsp_2_tl ( ru, rv, rcn, rth, rw, rvv,
% oru, orv, orcn, orth, orw, orvv,
% ruw1, rvw1, ut1, vt1, tt1, qt1,
% fit1, st1, tdt1, psdt1, nest_u, nest_v,
% wt1, topo, fipt1, mut1,
*
% rum, rvm, rcnm, rthm, rwm, rvvm,
% orum, orvm, orcnm, orthm, orwm, orvvm,
% ruw1m, rvw1m, ut1m, vt1m, tt1m, qt1m,
% fit1m, st1m, tdt1m,psdt1m,nestm_um,nestm_vm,
% wt1m, fipt1m, mut1m,
*
% LDIST_DIM,l_nk )
*
else
*
!$omp parallel
*
!$omp do
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
*
* TRAJECTORY
* ----------
rum (i,j,k) = orum (i,j,k)
rvm (i,j,k) = orvm (i,j,k)
rcnm(i,j,k) = orcnm(i,j,k)
rthm(i,j,k) = orthm(i,j,k)
*
* TLM
* ---
ru (i,j,k) = oru (i,j,k)
rv (i,j,k) = orv (i,j,k)
rcn(i,j,k) = orcn(i,j,k)
rth(i,j,k) = orth(i,j,k)
*
end do
end do
end do
!$omp end do
*
if (.not. Schm_hydro_L) then
!$omp do
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
*
* TRAJECTORY
* ----------
rwm (i,j,k) = orwm (i,j,k)
rvvm(i,j,k) = orvvm(i,j,k)
*
* TLM
* ---
rw (i,j,k) = orw (i,j,k)
rvv(i,j,k) = orvv(i,j,k)
*
end do
end do
end do
!$omp end do
endif
*
!$omp end parallel
*
endif
*
pnerr = vmmuld(-1,0)
*
1000 format(3X,'TLM of COMPUTE THE RIGHT-HAND-SIDES: (S/R RHS_TL)')
*
return
end