!-------------------------------------- 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 rhsp_2_tl - TLM of rhsp_2
*
#include "model_macros_f.h"
*
subroutine rhsp_2_tl ( F_ru, F_rv, F_rcn, F_rth, F_rw, F_rvv, 1
% F_oru, F_orv, F_orcn, F_orth, F_orw, F_orvv,
% F_ruw1, F_rvw1, F_u, F_v, F_t, F_q,
% F_fi, F_s, F_td, F_psd, F_nest_u, F_nest_v,
% F_w, F_fis, F_fip, F_mu,
*
% F_rum, F_rvm, F_rcnm, F_rthm, F_rwm, F_rvvm,
% F_orum, F_orvm, F_orcnm,F_orthm,F_orwm, F_orvvm,
% F_ruw1m,F_rvw1m,F_um, F_vm, F_tm, F_qm,
% F_fim, F_sm, F_tdm, F_psdm, F_nestm_um,F_nestm_vm,
% F_wm, F_fipm, F_mum,
*
% DIST_DIM, Nk )
*
implicit none
*
integer DIST_DIM, Nk
*
real F_ru (DIST_SHAPE,Nk), F_rv (DIST_SHAPE,Nk),
% F_rcn (DIST_SHAPE,Nk), F_rth (DIST_SHAPE,Nk),
% F_rw (DIST_SHAPE,Nk), F_rvv (DIST_SHAPE,Nk),
% F_oru (DIST_SHAPE,Nk), F_orv (DIST_SHAPE,Nk),
% F_orcn (DIST_SHAPE,Nk), F_orth (DIST_SHAPE,Nk),
% F_orw (DIST_SHAPE,Nk), F_orvv (DIST_SHAPE,Nk),
% F_ruw1 (DIST_SHAPE,Nk), F_rvw1 (DIST_SHAPE,Nk),
% F_nest_u(DIST_SHAPE,Nk), F_nest_v(DIST_SHAPE,Nk),
% F_u (DIST_SHAPE,Nk), F_v (DIST_SHAPE,Nk),
% F_t (DIST_SHAPE,Nk), F_q (DIST_SHAPE,Nk),
% F_fi (DIST_SHAPE,Nk), F_s (DIST_SHAPE) ,
% F_td (DIST_SHAPE,Nk), F_psd (DIST_SHAPE,Nk),
% F_w (DIST_SHAPE,Nk), F_fis (DIST_SHAPE) ,
% F_fip (DIST_SHAPE,Nk), F_mu (DIST_SHAPE,Nk)
*
real F_rum (DIST_SHAPE,Nk), F_rvm (DIST_SHAPE,Nk),
% F_rcnm (DIST_SHAPE,Nk), F_rthm (DIST_SHAPE,Nk),
% F_rwm (DIST_SHAPE,Nk), F_rvvm (DIST_SHAPE,Nk),
% F_orum (DIST_SHAPE,Nk), F_orvm (DIST_SHAPE,Nk),
% F_orcnm (DIST_SHAPE,Nk), F_orthm (DIST_SHAPE,Nk),
% F_orwm (DIST_SHAPE,Nk), F_orvvm (DIST_SHAPE,Nk),
% F_ruw1m (DIST_SHAPE,Nk), F_rvw1m (DIST_SHAPE,Nk),
% F_nestm_um(DIST_SHAPE,Nk), F_nestm_vm(DIST_SHAPE,Nk),
% F_um (DIST_SHAPE,Nk), F_vm (DIST_SHAPE,Nk),
% F_tm (DIST_SHAPE,Nk), F_qm (DIST_SHAPE,Nk),
% F_fim (DIST_SHAPE,Nk), F_sm (DIST_SHAPE) ,
% F_tdm (DIST_SHAPE,Nk), F_psdm (DIST_SHAPE,Nk),
% F_wm (DIST_SHAPE,Nk),
% F_fipm (DIST_SHAPE,Nk), F_mum (DIST_SHAPE,Nk)
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_31 - Tanguay M. - adapt for vertical hybrid coordinate and LAM version
* - 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_30 - Tanguay M. - Use invhsyv
* v3_31 - Tanguay M. - new scope for operator + adw_cliptraj (LAM)
*
*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
* Name I/O Description
*----------------------------------------------------------------
* F_ru O
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "cori.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "offc.cdk"
#include "schm.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
*
integer i, j, k, i0, j0, in, jn,i00,inn,j00,jnn,nij
real*8 aaa_8, bbb_8, ZERO_8, ONE_8, pd1_8
real*8 c1_8,c2_8,c3_8,c4_8,c5_8,c6_8,c7_8,c8_8
parameter( ZERO_8=0.0, ONE_8=1.0 )
* - - - - - - - - - - - - - - - -
*
real wk1 (DIST_SHAPE), wk2 (DIST_SHAPE)
real wk1m(DIST_SHAPE), wk2m(DIST_SHAPE)
*
real*8 xmassm_8(l_ni,l_nj), y1logm_8(l_ni,l_nj), y2logm_8(l_ni,l_nj),
$ expfm_8(l_ni,l_nj), invsm_8(l_ni,l_nj), invtm_8(l_ni,l_nj)
*
real*8 inv_Cstv_tstr_8
real*8 inv_Geomg_hx_8(l_niu)
real*8 inv_Geomg_z_8(l_nk)
*
* ______________________________________________________
*
* Common coefficients
aaa_8 = ( Offc_a1_8 / Offc_b0_8 )/ Cstv_dt_8
bbb_8 = ( Offc_b1_8 / Offc_b0_8 )
c1_8 = bbb_8 * Dcst_rgasd_8 / ( Dcst_rayt_8*Dcst_rayt_8 )
c2_8 = bbb_8 / ( Dcst_rayt_8*Dcst_rayt_8 )
c3_8 = aaa_8*Dcst_cappa_8
c4_8 = bbb_8*Dcst_cappa_8
c5_8 = aaa_8*Schm_nonhy_8
c6_8 = bbb_8*Dcst_grav_8
c7_8 = bbb_8*Dcst_rgasd_8*Cstv_tstr_8
if (Cori_cornl_L) then
c8_8 = Offc_b1_8 / Offc_b0_8
else
c8_8 = ( Offc_b1_8 - Offc_b0_8 ) / Offc_b0_8
endif
*
* Exchange haloes for derivatives & interpolation
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_um, LDIST_DIM,l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_vm, LDIST_DIM,l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_tm, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_qm, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_fim,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
if (.not. Schm_hydro_L) then
call rpn_comm_xch_halo( F_mum, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
endif
*
* TLM
* ---
call rpn_comm_xch_halo( F_u , LDIST_DIM,l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_v , LDIST_DIM,l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_t , LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_q , LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_fi, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
if (.not. Schm_hydro_L) then
call rpn_comm_xch_halo( F_mu, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
endif
*
nij = l_ni*l_nj
*
!$omp parallel
!$omp do
do j = 1, l_nj
do i = 1, l_ni
*
xmassm_8(i,j) = F_sm(i,j)
*
end do
end do
!$omp enddo
*
!$omp single
call vexp (expfm_8,xmassm_8,nij)
!$omp end single
*
inv_Cstv_tstr_8 = 1.0d0 / Cstv_tstr_8
*
!$omp do
do i = 1, l_niu
inv_Geomg_hx_8(i) = 1.0d0 / Geomg_hx_8(i)
end do
!$omp enddo
*
!$omp do
do k = 1, l_nk
inv_Geomg_z_8(k) = 1.0d0 / Geomg_z_8(k)
end do
!$omp enddo
!$omp end parallel
*
!$omp parallel private(i,j,i0,j0,jn,in,i00,inn,j00,jnn,
!$omp$ pd1_8,xmassm_8,y1logm_8,y2logm_8,
!$omp$ invsm_8,invtm_8,
!$omp$ wk1m,wk2m,wk1,wk2)
*
!$omp do
do 1000 k = 1,l_nk
*
if (Schm_hydro_L) then
do j = 1, l_nj
do i = 1, l_ni
*
* TRAJECTORY
* ----------
wk1m (i,j) = ONE_8
*
* TLM
* ---
wk1 (i,j) = ZERO_8
*
end do
end do
endif
*
*****************************
* Compute RHS of U equation *
*****************************
* set indices for calculating Ru
i0 = 1
j0 = 1
in = l_niu
jn = l_nj
if (.not. Schm_hydro_L) then
do j = j0, jn
do i = i0, in
*
* TRAJECTORY
* ----------
wk1m(i,j) = ( 1. - intuv_c0xxu_8(i) )*(1.+ F_mum(i ,j,k))
% + intuv_c0xxu_8(i) *(1.+ F_mum(i+1,j,k))
*
* TLM
* ---
wk1(i,j) = ( 1. - intuv_c0xxu_8(i) )*( F_mu(i ,j,k))
% + intuv_c0xxu_8(i) *( F_mu(i+1,j,k))
*
end do
end do
endif
if ( abs(c8_8) .lt. 1.0e-6 ) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rum(i,j,k)= - aaa_8*F_um(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_tm(i ,j,k)
% + intuv_c0xxu_8(i) * F_tm(i+1,j,k) )
% * ( F_qm (i+1,j,k) - F_qm (i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c2_8 *wk1m(i,j)*( F_fim(i+1,j,k) - F_fim(i,j,k) ) * inv_Geomg_hx_8(i)
*
F_orum(i,j,k) = F_rum (i,j,k)
*
* TLM
* ---
F_ru(i,j,k) = - aaa_8*F_u(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_tm(i ,j,k)
% + intuv_c0xxu_8(i) * F_tm(i+1,j,k) )
% * ( F_q (i+1,j,k) - F_q (i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_t(i ,j,k)
% + intuv_c0xxu_8(i) * F_t(i+1,j,k) )
% * ( F_qm(i+1,j,k) - F_qm(i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c2_8 *wk1m(i,j)*( F_fi (i+1,j,k) - F_fi (i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c2_8 *wk1 (i,j)*( F_fim(i+1,j,k) - F_fim(i,j,k) ) * inv_Geomg_hx_8(i)
*
F_oru(i,j,k) = F_ru (i,j,k)
end do
end do
else
* Set indices for calculating wk2
i00=minx
inn=maxx
j00 = 1
jnn = l_njv
if (l_south) j00 = 3
if (l_north) jnn = l_njv-1
*
do j = j00, jnn
do i = i00, inn
*
* TRAJECTORY
* ----------
wk2m(i,j) = inuvl_wyvy3_8(j,1) * F_vm(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * F_vm(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * F_vm(i,j ,k)
% + inuvl_wyvy3_8(j,4) * F_vm(i,j+1,k)
*
* TLM
* ---
wk2(i,j) = inuvl_wyvy3_8(j,1) * F_v(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * F_v(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * F_v(i,j ,k)
% + inuvl_wyvy3_8(j,4) * F_v(i,j+1,k)
end do
end do
*
if (.not.G_lam) then
if (l_south) then
do i = i00, inn
*
* TRAJECTORY
* ----------
wk2m(i,j00-2)= inuvl_wyvy3_8(j00-2,3) * F_vm(i,j00-2,k)
% + inuvl_wyvy3_8(j00-2,4) * F_vm(i,j00-1,k)
wk2m(i,j00-1)= inuvl_wyvy3_8(j00-1,2) * F_vm(i,j00-2,k)
% + inuvl_wyvy3_8(j00-1,3) * F_vm(i,j00-1,k)
% + inuvl_wyvy3_8(j00-1,4) * F_vm(i,j00 ,k)
*
* TLM
* ---
wk2(i,j00-2)= inuvl_wyvy3_8(j00-2,3) * F_v(i,j00-2,k)
% + inuvl_wyvy3_8(j00-2,4) * F_v(i,j00-1,k)
wk2(i,j00-1)= inuvl_wyvy3_8(j00-1,2) * F_v(i,j00-2,k)
% + inuvl_wyvy3_8(j00-1,3) * F_v(i,j00-1,k)
% + inuvl_wyvy3_8(j00-1,4) * F_v(i,j00 ,k)
end do
endif
if (l_north) then
do i = i00, inn
*
* TRAJECTORY
* ----------
wk2m(i,jnn+2)= inuvl_wyvy3_8(jnn+2,1) * F_vm(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+2,2) * F_vm(i,jnn+1,k)
wk2m(i,jnn+1)= inuvl_wyvy3_8(jnn+1,1) * F_vm(i,jnn-1,k)
% + inuvl_wyvy3_8(jnn+1,2) * F_vm(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+1,3) * F_vm(i,jnn+1,k)
*
* TLM
* ---
wk2(i,jnn+2)= inuvl_wyvy3_8(jnn+2,1) * F_v(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+2,2) * F_v(i,jnn+1,k)
wk2(i,jnn+1)= inuvl_wyvy3_8(jnn+1,1) * F_v(i,jnn-1,k)
% + inuvl_wyvy3_8(jnn+1,2) * F_v(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+1,3) * F_v(i,jnn+1,k)
end do
endif
*
endif
*
* Set indices for calculating Ru
if (G_lam) then
if (l_west ) i0 = 2
if (l_east ) in = l_niu-1
if (l_south) j0 = 3
if (l_north) jn = l_njv-1
endif
*
* Adding coriolis factor to Ru
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rum(i,j,k) = - aaa_8*F_um(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_tm(i ,j,k)
% + intuv_c0xxu_8(i) * F_tm(i+1,j,k) )
% * ( F_qm(i+1,j,k) - F_qm(i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c2_8 *wk1m(i,j) * ( F_fim(i+1,j,k) - F_fim(i,j,k) )
% * inv_Geomg_hx_8(i)
*
% + c8_8 * Cori_fcoru_8(i,j) *
% (inuvl_wxxu3_8(i,1)*wk2m(i-1,j)+inuvl_wxxu3_8(i,2)*wk2m(i ,j)
% + inuvl_wxxu3_8(i,3)*wk2m(i+1,j)+inuvl_wxxu3_8(i,4)*wk2m(i+2,j))
*
F_orum(i,j,k) = F_rum(i,j,k)
*
* TLM
* ---
F_ru(i,j,k) = - aaa_8*F_u(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_tm(i ,j,k)
% + intuv_c0xxu_8(i) * F_tm(i+1,j,k) )
% * ( F_q (i+1,j,k) - F_q (i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_t(i ,j,k)
% + intuv_c0xxu_8(i) * F_t(i+1,j,k) )
% * ( F_qm(i+1,j,k) - F_qm(i,j,k) ) * inv_Geomg_hx_8(i)
*
% - c2_8 *wk1m(i,j) * ( F_fi (i+1,j,k) - F_fi (i,j,k) )
% * inv_Geomg_hx_8(i)
*
% - c2_8 *wk1 (i,j) * ( F_fim(i+1,j,k) - F_fim(i,j,k) )
% * inv_Geomg_hx_8(i)
*
% + c8_8 * Cori_fcoru_8(i,j) *
% (inuvl_wxxu3_8(i,1)*wk2(i-1,j)+inuvl_wxxu3_8(i,2)*wk2(i ,j)
% + inuvl_wxxu3_8(i,3)*wk2(i+1,j)+inuvl_wxxu3_8(i,4)*wk2(i+2,j))
F_oru(i,j,k) = F_ru (i,j,k)
end do
end do
endif
*****************************
* Compute RHS of V equation *
*****************************
* set indices for calculating Rv
i0 = 1
j0 = 1
in = l_ni
jn = l_njv
if (.not. Schm_hydro_L) then
do j = j0, jn
do i = i0, in
*
* TRAJECTORY
* ----------
wk1m(i,j) = ( 1. - intuv_c0yyv_8(j) )*(1.+F_mum(i,j ,k))
% + intuv_c0yyv_8(j) *(1.+F_mum(i,j+1,k))
*
* TLM
* ---
wk1 (i,j) = ( 1. - intuv_c0yyv_8(j) )*(F_mu(i,j ,k))
% + intuv_c0yyv_8(j) *(F_mu(i,j+1,k))
*
end do
end do
endif
*
if ( abs(c8_8) .lt. 1.0e-6 ) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rvm(i,j,k) = - aaa_8*F_vm(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_tm(i,j ,k)
% + intuv_c0yyv_8(j) *F_tm(i,j+1,k) )
% * ( F_qm (i,j+1,k) - F_qm (i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c2_8 *wk1m(i,j)*( F_fim(i,j+1,k) - F_fim(i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
F_orvm(i,j,k) = F_rvm (i,j,k)
*
* TLM
* ---
F_rv(i,j,k) = - aaa_8*F_v(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_tm(i,j ,k)
% + intuv_c0yyv_8(j) *F_tm(i,j+1,k) )
% * ( F_q (i,j+1,k) - F_q (i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_t(i,j ,k)
% + intuv_c0yyv_8(j) *F_t(i,j+1,k) )
% * ( F_qm(i,j+1,k) - F_qm(i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c2_8 *wk1m(i,j)*( F_fi (i,j+1,k) - F_fi (i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c2_8 *wk1 (i,j)*( F_fim(i,j+1,k) - F_fim(i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
F_orv(i,j,k) = F_rv (i,j,k)
end do
end do
else
*
* Set indices for calculating wk2
j00=miny
jnn=maxy
i00 = 1
inn = l_niu
if (G_lam) then
if (l_west) i00 = 3
if (l_east) inn = l_niu-1
endif
*
do j = j00, jnn
do i = i00, inn
*
* TRAJECTORY
* ----------
wk2m(i,j) = inuvl_wxux3_8(i,1)*F_um(i-2,j,k)
% + inuvl_wxux3_8(i,2)*F_um(i-1,j,k)
% + inuvl_wxux3_8(i,3)*F_um(i ,j,k)
% + inuvl_wxux3_8(i,4)*F_um(i+1,j,k)
*
* TLM
* ---
wk2(i,j) = inuvl_wxux3_8(i,1)*F_u(i-2,j,k)
% + inuvl_wxux3_8(i,2)*F_u(i-1,j,k)
% + inuvl_wxux3_8(i,3)*F_u(i ,j,k)
% + inuvl_wxux3_8(i,4)*F_u(i+1,j,k)
end do
end do
*
* Set indices for calculating Rv
if (l_south) j0 = 2
if (l_north) jn = l_njv-1
if (G_lam) then
if (l_west) i0 = 3
if (l_east) in = l_niu-1
endif
*
* Adding coriolis factor to Rv
do j = j0, jn
do i = i0, in
*
* TRAJECTORY
* ----------
F_rvm(i,j,k) = - aaa_8*F_vm(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_tm(i,j ,k)
% + intuv_c0yyv_8(j) *F_tm(i,j+1,k) )
% * (F_qm(i,j+1,k)-F_qm(i,j,k))*Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c2_8 *wk1m(i,j)*( F_fim(i,j+1,k) - F_fim(i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c8_8 * Cori_fcorv_8(i,j) *
% (inuvl_wyyv3_8(j,1)*wk2m(i,j-1)+inuvl_wyyv3_8(j,2)*wk2m(i,j )
% + inuvl_wyyv3_8(j,3)*wk2m(i,j+1)+inuvl_wyyv3_8(j,4)*wk2m(i,j+2))
*
F_orvm(i,j,k) = F_rvm(i,j,k)
*
* TLM
* ---
F_rv(i,j,k) = - aaa_8*F_v(i,j,k)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_tm(i,j ,k)
% + intuv_c0yyv_8(j) *F_tm(i,j+1,k) )
% * (F_q(i,j+1,k)-F_q (i,j,k))*Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_t(i,j ,k)
% + intuv_c0yyv_8(j) *F_t(i,j+1,k) )
% * (F_qm(i,j+1,k)-F_qm(i,j,k))*Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c2_8 *wk1m(i,j)*( F_fi (i,j+1,k) - F_fi (i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c2_8 *wk1 (i,j)*( F_fim(i,j+1,k) - F_fim(i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
*
% - c8_8 * Cori_fcorv_8(i,j) *
% (inuvl_wyyv3_8(j,1)*wk2(i,j-1)+inuvl_wyyv3_8(j,2)*wk2(i,j )
% + inuvl_wyyv3_8(j,3)*wk2(i,j+1)+inuvl_wyyv3_8(j,4)*wk2(i,j+2))
*
F_orv(i,j,k) = F_rv (i,j,k)
end do
end do
*
if (.not.G_lam) then
if (l_south) then
do i = i0, in
*
* TRAJECTORY
* ----------
F_rvm(i,1,k) = - aaa_8*F_vm(i,1,k)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(1) )*F_tm(i,1 ,k)
% + intuv_c0yyv_8(1) *F_tm(i,1+1,k) )
% * (F_qm(i,1+1,k)-F_qm(i,1,k))*Geomg_cyv2_8(1) * Geomg_invhsy_8(1)
*
% - c2_8 * wk1m(i,1) * ( F_fim(i,1+1,k) - F_fim(i,1,k) )
% * Geomg_cyv2_8(1) * Geomg_invhsy_8(1)
*
% - c8_8 * Cori_fcorv_8(i,1)
% * (inuvl_wyyv3_8(1,2)*wk2m(i,1)+inuvl_wyyv3_8(1,3)*wk2m(i,2)
% +inuvl_wyyv3_8(1,4)*wk2m(i,3))
*
F_orvm(i,1,k) = F_rvm(i,1,k)
*
* TLM
* ---
F_rv(i,1,k) = - aaa_8*F_v(i,1,k)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(1) )*F_tm(i,1 ,k)
% + intuv_c0yyv_8(1) *F_tm(i,1+1,k) )
% * (F_q (i,1+1,k)-F_q(i,1,k))*Geomg_cyv2_8(1) * Geomg_invhsy_8(1)
*
% - c1_8 *( ( 1. - intuv_c0yyv_8(1) )*F_t(i,1 ,k)
% + intuv_c0yyv_8(1) *F_t(i,1+1,k) )
% * (F_qm(i,1+1,k)-F_qm(i,1,k))*Geomg_cyv2_8(1) * Geomg_invhsy_8(1)
*
% - c2_8 * wk1m(i,1) * ( F_fi (i,1+1,k) - F_fi (i,1,k) )
% * Geomg_cyv2_8(1) * Geomg_invhsy_8(1)
*
% - c2_8 * wk1 (i,1) * ( F_fim(i,1+1,k) - F_fim(i,1,k) )
% * Geomg_cyv2_8(1) * Geomg_invhsy_8(1)
*
% - c8_8 * Cori_fcorv_8(i,1)
% * (inuvl_wyyv3_8(1,2)*wk2(i,1)+inuvl_wyyv3_8(1,3)*wk2(i,2)
% +inuvl_wyyv3_8(1,4)*wk2(i,3))
*
F_orv(i,1,k) = F_rv (i,1,k)
end do
endif
*
if (l_north) then
do i = i0, in
*
* TRAJECTORY
* ----------
F_rvm(i,l_njv,k) = - aaa_8*F_vm(i,l_njv,k)
*
% - c1_8 *(( 1. - intuv_c0yyv_8(l_njv) )*F_tm(i,l_njv ,k)
% + intuv_c0yyv_8(l_njv) *F_tm(i,l_njv+1,k))
% * ( F_qm(i,l_njv+1,k) - F_qm(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv) * Geomg_invhsy_8(l_njv)
*
% - c2_8 *wk1m(i,l_njv)*( F_fim(i,l_njv+1,k)
% - F_fim(i,l_njv,k))*Geomg_cyv2_8(l_njv) * Geomg_invhsy_8(l_njv)
*
% - c8_8 * Cori_fcorv_8(i,l_njv) *
% ( inuvl_wyyv3_8(l_njv,1)*wk2m(i,l_njv-1)
% + inuvl_wyyv3_8(l_njv,2)*wk2m(i,l_njv )
% + inuvl_wyyv3_8(l_njv,3)*wk2m(i,l_njv+1) )
*
F_orvm(i,l_njv,k) = F_rvm(i,l_njv,k)
*
* TLM
* ---
F_rv(i,l_njv,k) = - aaa_8*F_v(i,l_njv,k)
*
% - c1_8 *(( 1. - intuv_c0yyv_8(l_njv) )*F_tm(i,l_njv ,k)
% + intuv_c0yyv_8(l_njv) *F_tm(i,l_njv+1,k))
% * ( F_q(i,l_njv+1,k) - F_q(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv) * Geomg_invhsy_8(l_njv)
*
% - c1_8 *(( 1. - intuv_c0yyv_8(l_njv) )*F_t(i,l_njv ,k)
% + intuv_c0yyv_8(l_njv) *F_t(i,l_njv+1,k))
% * ( F_qm(i,l_njv+1,k) - F_qm(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv) * Geomg_invhsy_8(l_njv)
*
% - c2_8 *wk1m(i,l_njv)*( F_fi (i,l_njv+1,k)
% - F_fi (i,l_njv,k))*Geomg_cyv2_8(l_njv) * Geomg_invhsy_8(l_njv)
*
% - c2_8 *wk1 (i,l_njv)*( F_fim(i,l_njv+1,k)
% - F_fim(i,l_njv,k))*Geomg_cyv2_8(l_njv) * Geomg_invhsy_8(l_njv)
*
% - c8_8 * Cori_fcorv_8(i,l_njv) *
% ( inuvl_wyyv3_8(l_njv,1)*wk2(i,l_njv-1)
% + inuvl_wyyv3_8(l_njv,2)*wk2(i,l_njv )
% + inuvl_wyyv3_8(l_njv,3)*wk2(i,l_njv+1) )
*
F_orv(i,l_njv,k) = F_rv (i,l_njv,k)
end do
endif
endif
endif
* RHS of continuity, thermodynamic, passive advection equations *
i0 = 1
j0 = 1
in = l_ni
jn = l_nj
*
do j = j0, jn
do i = i0, in
xmassm_8(i,j) = ONE_8+Geomg_dpba(k)*(expfm_8(i,j) - ONE_8)
end do
end do
call vlog(y1logm_8, xmassm_8, nij)
call vrec( invsm_8, xmassm_8, nij)
*
do j = j0, jn
do i = i0, in
xmassm_8(i,j) = F_tm(i,j,k)*inv_Cstv_tstr_8
end do
end do
call vlog(y2logm_8, xmassm_8, nij)
call vrec( invtm_8, xmassm_8, nij)
*
pd1_8 = log(Geomg_z_8(k))
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rcnm(i,j,k) = - aaa_8*y1logm_8(i,j) - bbb_8*F_tdm(i,j,k)
*
F_rthm(i,j,k) = - aaa_8*y2logm_8(i,j) - c3_8*(pd1_8-F_qm(i,j,k))
*
% + c4_8*F_psdm(i,j,k)*inv_Geomg_z_8(k)
*
F_orcnm(i,j,k)= F_rcnm(i,j,k)
F_orthm(i,j,k)= F_rthm(i,j,k)
*
* TLM
* ---
F_rcn(i,j,k) = - aaa_8*(Geomg_dpba(k)*(F_s(i,j)*expfm_8(i,j))) * invsm_8(i,j)
% - bbb_8*F_td(i,j,k)
*
F_rth(i,j,k) = - aaa_8*( F_t(i,j,k) * inv_Cstv_tstr_8 ) * invtm_8(i,j)
% - c3_8 *(-F_q(i,j,k))
*
% + c4_8 *F_psd(i,j,k) * inv_Geomg_z_8(k)
*
F_orcn(i,j,k)= F_rcn(i,j,k)
F_orth(i,j,k)= F_rth(i,j,k)
end do
end do
*
* RHS of vertical momentum, vertical velocity equation *
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rwm (i,j,k) = - c5_8*F_wm(i,j,k) + c6_8*F_mum(i,j,k)
*
F_rvvm(i,j,k) = - aaa_8*( F_fis(i,j) + F_fipm(i,j,k) )
% + c7_8*F_psdm(i,j,k)*inv_Geomg_z_8(k)+c6_8*F_wm(i,j,k)
*
F_orwm (i,j,k) = F_rwm (i,j,k)
*
F_orvvm(i,j,k) = F_rvvm(i,j,k)
*
* TLM
* ---
F_rw (i,j,k) = - c5_8*F_w(i,j,k) + c6_8*F_mu(i,j,k)
*
F_rvv(i,j,k) = - aaa_8*( F_fip(i,j,k) )
% + c7_8*F_psd(i,j,k)*inv_Geomg_z_8(k)+c6_8*F_w(i,j,k)
*
F_orw (i,j,k) = F_rw (i,j,k)
F_orvv(i,j,k) = F_rvv(i,j,k)
end do
end do
endif
1000 continue
!$omp enddo
*
*******************************************************
* Interpolate Ru, Rv from U-, V-grid to G-grid, resp. *
*******************************************************
*
!$omp single
* TRAJECTORY
* ----------
call rpn_comm_xch_halo ( F_rum,LDIST_DIM,l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo ( F_rvm,LDIST_DIM,l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* TLM
* ---
call rpn_comm_xch_halo ( F_ru, LDIST_DIM,l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo ( F_rv, LDIST_DIM,l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
!$omp end single
*
* set indices for Ruw1
i0 = 1
in = l_niu
j0 = 1
jn = l_nj
if (G_lam) then
if (l_west) i0 = 4
if (l_east) in = l_niu - 2
if (l_south) j0 = 4
if (l_north) jn = l_njv - 2
endif
*
!$omp do
do k=1,l_nk
do j = j0, jn
do i = i0, in
*
* TRAJECTORY
* ----------
F_ruw1m(i,j,k) = inuvl_wxux3_8(i,1) * F_rum(i-2,j,k)
$ + inuvl_wxux3_8(i,2) * F_rum(i-1,j,k)
$ + inuvl_wxux3_8(i,3) * F_rum(i ,j,k)
$ + inuvl_wxux3_8(i,4) * F_rum(i+1,j,k)
*
* TLM
* ---
F_ruw1(i,j,k) = inuvl_wxux3_8(i,1) * F_ru(i-2,j,k)
$ + inuvl_wxux3_8(i,2) * F_ru(i-1,j,k)
$ + inuvl_wxux3_8(i,3) * F_ru(i ,j,k)
$ + inuvl_wxux3_8(i,4) * F_ru(i+1,j,k)
end do
end do
end do
!$omp enddo
*
* set indices for Rvw1
i0 = 1
in = l_ni
j0 = 1
jn = l_njv
if (l_south) j0 = 3
if (l_north) jn = l_njv-1
if (G_lam) then
if (l_west) i0 = 4
if (l_east) in = l_niu - 2
if (l_south) j0 = 4
if (l_north) jn = l_njv - 2
endif
*
!$omp do
do k=1,l_nk
do j = j0, jn
do i = i0, in
*
* TRAJECTORY
* ----------
F_rvw1m(i,j,k) = inuvl_wyvy3_8(j,1) * F_rvm(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * F_rvm(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * F_rvm(i,j ,k)
% + inuvl_wyvy3_8(j,4) * F_rvm(i,j+1,k)
*
* TLM
* ---
F_rvw1(i,j,k) = inuvl_wyvy3_8(j,1) * F_rv(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * F_rv(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * F_rv(i,j ,k)
% + inuvl_wyvy3_8(j,4) * F_rv(i,j+1,k)
end do
end do
if (.not.G_lam) then
if (l_south) then
do i = i0, in
*
* TRAJECTORY
* ----------
F_rvw1m(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * F_rvm(i,j0-2,k)
% + inuvl_wyvy3_8(j0-2,4) * F_rvm(i,j0-1,k)
F_rvw1m(i,j0-1,k) = inuvl_wyvy3_8(j0-1,2) * F_rvm(i,j0-2,k)
% + inuvl_wyvy3_8(j0-1,3) * F_rvm(i,j0-1,k)
% + inuvl_wyvy3_8(j0-1,4) * F_rvm(i,j0,k )
*
* TLM
* ---
F_rvw1(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * F_rv(i,j0-2,k)
% + inuvl_wyvy3_8(j0-2,4) * F_rv(i,j0-1,k)
F_rvw1(i,j0-1,k) = inuvl_wyvy3_8(j0-1,2) * F_rv(i,j0-2,k)
% + inuvl_wyvy3_8(j0-1,3) * F_rv(i,j0-1,k)
% + inuvl_wyvy3_8(j0-1,4) * F_rv(i,j0,k )
end do
endif
if (l_north) then
do i = i0, in
*
* TRAJECTORY
* ----------
F_rvw1m(i,jn+2,k) = inuvl_wyvy3_8(jn+2,1) * F_rvm(i,jn ,k)
% + inuvl_wyvy3_8(jn+2,2) * F_rvm(i,jn+1,k)
F_rvw1m(i,jn+1,k) = inuvl_wyvy3_8(jn+1,1) * F_rvm(i,jn-1,k)
% + inuvl_wyvy3_8(jn+1,2) * F_rvm(i,jn ,k)
% + inuvl_wyvy3_8(jn+1,3) * F_rvm(i,jn+1,k)
* TLM
* ---
F_rvw1(i,jn+2,k) = inuvl_wyvy3_8(jn+2,1) * F_rv(i,jn ,k)
% + inuvl_wyvy3_8(jn+2,2) * F_rv(i,jn+1,k)
F_rvw1(i,jn+1,k) = inuvl_wyvy3_8(jn+1,1) * F_rv(i,jn-1,k)
% + inuvl_wyvy3_8(jn+1,2) * F_rv(i,jn ,k)
% + inuvl_wyvy3_8(jn+1,3) * F_rv(i,jn+1,k)
end do
endif
endif
end do
!$omp enddo
*
* Change Ru, Rv values on the boundaries of the LAM grid
*
if (G_lam) then
if (l_west) then
!$omp do
do k=1,l_nk
do j= 1+pil_s, l_nj-pil_n
*
* TRAJECTORY
* ----------
F_rum(pil_w,j,k) = - aaa_8*F_nestm_um(pil_w,j,k)
F_orum(pil_w,j,k) = F_rum(pil_w,j,k)
*
* TLM
* ---
F_ru(pil_w,j,k) = - aaa_8*F_nest_u(pil_w,j,k)
F_oru(pil_w,j,k) = F_ru(pil_w,j,k)
enddo
enddo
!$omp enddo
endif
if (l_east) then
!$omp do
do k=1,l_nk
do j= 1+pil_s, l_nj-pil_n
*
* TRAJECTORY
* ----------
F_rum(l_ni-pil_e,j,k) = - aaa_8*F_nestm_um(l_ni-pil_e,j,k)
F_orum(l_ni-pil_e,j,k) = F_rum(l_ni-pil_e,j,k)
*
* TLM
* ---
F_ru(l_ni-pil_e,j,k) = - aaa_8*F_nest_u(l_ni-pil_e,j,k)
F_oru(l_ni-pil_e,j,k) = F_ru(l_ni-pil_e,j,k)
enddo
enddo
!$omp enddo
endif
if (l_south) then
!$omp do
do k=1,l_nk
do i= 1+pil_w, l_ni-pil_e
*
* TRAJECTORY
* ----------
F_rvm(i,pil_s,k) = - aaa_8*F_nestm_vm(i,pil_s,k)
F_orvm(i,pil_s,k) = F_rvm(i,pil_s,k)
*
* TLM
* ---
F_rv(i,pil_s,k) = - aaa_8*F_nest_v(i,pil_s,k)
F_orv(i,pil_s,k) = F_rv(i,pil_s,k)
enddo
enddo
!$omp enddo
endif
if (l_north) then
!$omp do
do k=1,l_nk
do i= 1+pil_w, l_ni-pil_e
*
* TRAJECTORY
* ----------
F_rvm(i,l_nj-pil_n,k) = - aaa_8*F_nestm_vm(i,l_nj-pil_n,k)
F_orvm(i,l_nj-pil_n,k) = F_rvm(i,l_nj-pil_n,k)
*
* TLM
* ---
F_rv(i,l_nj-pil_n,k) = - aaa_8*F_nest_v(i,l_nj-pil_n,k)
F_orv(i,l_nj-pil_n,k) = F_rv(i,l_nj-pil_n,k)
enddo
enddo
!$omp enddo
endif
endif
*
!$omp end parallel
*
return
end