!-------------------------------------- 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_ad - ADJ of rhs_tl
*
#include "model_macros_f.h"
*
subroutine rhs_ad() 1,1
*
implicit none
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_21 - Tanguay M. - reduce standard output as in model
* v2_31 - Tanguay M. - adapt for vertical hybrid coordinate
* - adapt for tracers in tr3d
* v3_03 - Tanguay M. - Adjoint Lam and NoHyd configuration
* v3_11 - Tanguay M. - Correction TRAJ wk1m NoHyd
* - AIXport+Opti+OpenMP for TLM-ADJ
* v3_21 - Tanguay M. - Revision Openmp
*
*object
* see id section
* -----------------------------------------
* REMARK:INPUT TRAJ:F_tm, F_qm, F_sm, F_fim
* -----------------------------------------
*
*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 "vt1m.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
*
integer pnerr, pnlod, pnlkey1(100), i, j, k
*
real*8, parameter :: ZERO_8 = 0.0
* ______________________________________________________
*
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(tt1m)
pnlkey1(pnlod + 2 ) = VMM_KEY(qt1m)
pnlkey1(pnlod + 3 ) = VMM_KEY(st1m)
pnlkey1(pnlod + 4 ) = VMM_KEY(fit1m)
pnlod = pnlod + 4
if (.not. Schm_hydro_L) then
pnlkey1(pnlod+1) = VMM_KEY(mut1m)
pnlod = pnlod+1
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(tt1m)
pnerr = VMM_GET_VAR(qt1m)
pnerr = VMM_GET_VAR(st1m)
pnerr = VMM_GET_VAR(fit1m)
if (.not. Schm_hydro_L) pnerr = VMM_GET_VAR(mut1m)
*
* Perform the computation in the first
* cycle of Crank-Nicholson procedure only
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if ( Orh_icn .eq. 1 ) then
*
call rhsp_2_ad ( 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,
*
% tt1m, qt1m,
% fit1m, st1m,
% mut1m,
*
% LDIST_DIM,l_nk )
*
else
*
!$omp parallel
*
if (.not. Schm_hydro_L) then
!$omp do
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
*
orvv(i,j,k) = rvv(i,j,k) + orvv(i,j,k)
rvv (i,j,k) = ZERO_8
*
orw (i,j,k) = rw (i,j,k) + orw (i,j,k)
rw (i,j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
endif
*
!$omp do
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
*
orth(i,j,k) = rth(i,j,k) + orth(i,j,k)
rth(i,j,k) = 0.
*
orcn(i,j,k) = rcn(i,j,k) + orcn(i,j,k)
rcn(i,j,k) = 0.
*
orv (i,j,k) = rv (i,j,k) + orv (i,j,k)
rv (i,j,k) = 0.
*
oru (i,j,k) = ru (i,j,k) + oru (i,j,k)
ru (i,j,k) = 0.
*
end do
end do
end do
!$omp end do
*
!$omp end parallel
*
endif
*
pnerr = vmmuld(-1,0)
*
1000 format(3X,'ADJ of COMPUTE THE RIGHT-HAND-SIDES: (S/R RHS_AD)',/)
return
end