!-------------------------------------- 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 prep_2_tl - TLM of prep_2
*
#include "model_macros_f.h"
*
subroutine prep_2_tl ( F_ru, F_rv, F_ruw1, F_ruw2, F_rvw1, F_rvw2, 1,2
$ F_xct1, F_yct1, F_zct1, F_fis, F_rd, F_rcn,
$ F_r1, F_rth, F_rw, F_rvv, F_r3, F_r3p,
$ F_rhell, F_wijk1, F_wijk2,
*
$ F_rum, F_rvm, F_ruw1m, F_ruw2m,F_rvw1m,F_rvw2m,
$ F_xct1m, F_yct1m, F_zct1m, F_rdm, F_rcnm,
$ F_r1m, F_rthm, F_rwm, F_rvvm, F_r3m, F_r3pm,
$ F_rhellm,F_wijk1m,F_wijk2m,
*
$ DIST_DIM,ni,nj,Nk )
*
implicit none
*
integer DIST_DIM, ni, nj, Nk
real F_ru (DIST_SHAPE,Nk), F_rv (DIST_SHAPE,Nk),
% F_ruw1 (DIST_SHAPE,Nk), F_ruw2 (DIST_SHAPE,Nk),
% F_rvw1 (DIST_SHAPE,Nk), F_rvw2 (DIST_SHAPE,Nk),
% F_xct1 (ni,nj,Nk), F_yct1 (ni,nj,Nk), F_zct1 (ni,nj,Nk),
% F_rd (DIST_SHAPE,Nk), F_rcn (DIST_SHAPE,Nk),
% F_r1 (DIST_SHAPE,Nk), F_rth (DIST_SHAPE,Nk),
% F_rw (DIST_SHAPE,Nk), F_rvv (DIST_SHAPE,Nk),
% F_r3 (DIST_SHAPE,Nk), F_r3p (DIST_SHAPE,Nk),
% F_rhell(DIST_SHAPE,Nk), F_fis (DIST_SHAPE) ,
% F_wijk1(DIST_SHAPE,Nk), F_wijk2(DIST_SHAPE,Nk)
*
real F_rum (DIST_SHAPE,Nk), F_rvm (DIST_SHAPE,Nk),
% F_ruw1m (DIST_SHAPE,Nk), F_ruw2m (DIST_SHAPE,Nk),
% F_rvw1m (DIST_SHAPE,Nk), F_rvw2m (DIST_SHAPE,Nk),
% F_xct1m (ni,nj,Nk), F_yct1m (ni,nj,Nk), F_zct1m (ni,nj,Nk),
% F_rdm (DIST_SHAPE,Nk), F_rcnm (DIST_SHAPE,Nk),
% F_r1m (DIST_SHAPE,Nk), F_rthm (DIST_SHAPE,Nk),
% F_rwm (DIST_SHAPE,Nk), F_rvvm (DIST_SHAPE,Nk),
% F_r3m (DIST_SHAPE,Nk), F_r3pm (DIST_SHAPE,Nk),
% F_rhellm(DIST_SHAPE,Nk),
% F_wijk1m(DIST_SHAPE,Nk), F_wijk2m(DIST_SHAPE,Nk)
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_31 - Tanguay M. - adapt ADJ for new advection code and LAM version
* v3_00 - Tanguay M. - adapt to restructured prep_2
* 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_ruw2m, F_rvw2m, F_xct1m, F_yct1m, F_zct1m
* F_ruw1m, F_rvw1m, F_rum, F_rvm, F_rcnm
* F_rthm
* --------------------------------------------------------------
*
*arguments
* see appropriate comdeck documentation
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "grd.cdk"
#include "geomg.cdk"
#include "offc.cdk"
#include "schm.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
#include "adw.cdk"
#include "cori.cdk"
*
integer i, j, k, i0, j0, in, jn, i00, inn, j00, jnn
real*8 x_8, y_8, z_8, cx_8, cy_8, cz_8, rx_8, ry_8, rz_8
real*8 b1ob0_8, mumu_8, tot_8
real*8 a1_8, a2_8, b1_8, b2_8, b3_8, ccc_8, eps_8, gamma_8
*
real*8 ZERO_8, ONE_8, TWO_8, FOUR_8, HALF_8, QUARTER_8
parameter( ZERO_8=0.0, ONE_8=1.0, TWO_8=2.0, FOUR_8=4.0,
$ HALF_8=0.5, QUARTER_8=.25 )
*
real wij1(DIST_SHAPE),wij2(DIST_SHAPE)
*
real*8 cxm_8, cym_8, czm_8, rxm_8, rym_8, rzm_8, mumum_8
*
*
******************************************************************
* Metric corrections to the RHS of horizontal momentum equations *
******************************************************************
ccc_8 = ONE_8/( Dcst_rayt_8*Dcst_rayt_8 )
tot_8 = - FOUR_8*Dcst_omega_8/Cstv_dt_8
b1ob0_8 = Offc_b1_8/Offc_b0_8
gamma_8 = ONE_8
if (.not. Schm_hydro_L) then
eps_8 = Schm_nonhy_8 * Dcst_rgasd_8 * Cstv_tstr_8
% /( Dcst_cappa_8 * Dcst_grav_8**2 * Cstv_tau_8**2 )
gamma_8 = ONE_8/( ONE_8 + eps_8 )
endif
*
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
endif
*
!$omp parallel private(x_8,y_8,z_8,cx_8,cy_8,cz_8,
!$omp& rx_8,ry_8,rz_8,mumu_8,i,j,k,
!$omp& a1_8,a2_8,b1_8,b2_8,b3_8,
!$omp& cxm_8,cym_8,czm_8,rxm_8,rym_8,rzm_8,mumum_8)
!$omp do
do 100 k=1,l_nk
do 100 j= j0, jn
do 100 i= i0, in
* Compute components of r(t0) and put in x, y, z
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* CONSTANT
* --------
y_8 = adw_cy_8(j)
if (G_lam) then
x_8 = adw_cx_8(i) * y_8
y_8 = adw_sx_8(i) * y_8
else
x_8 = adw_cx_8(l_i0 - 1 + i) * y_8
y_8 = adw_sx_8(l_i0 - 1 + i) * y_8
endif
z_8 = adw_sy_8(j)
*
* Compute (Rx, Ry, Rz) = (rx, ry, rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* TRAJECTORY
* ----------
mumum_8 = ( ONE_8 + F_zct1m(i,j,k) )*( ONE_8 - F_zct1m(i,j,k) )
*
* TLM
* ---
mumu_8 = ( F_zct1 (i,j,k) )*( ONE_8 - F_zct1m(i,j,k) )
% + ( ONE_8 + F_zct1m(i,j,k) )*( - F_zct1 (i,j,k) )
*
* TRAJECTORY and TLM
* ------------------
if (mumum_8 .GT. ZERO_8) then
mumu_8 = - ( ONE_8 / mumum_8**2) * mumu_8
mumum_8 = ONE_8 / mumum_8
endif
*
* TRAJECTORY
* ----------
rzm_8 = F_rvw2m(i,j,k)
rym_8 = mumum_8 * (F_xct1m(i,j,k)*F_ruw2m(i,j,k)-
$ F_yct1m(i,j,k)*F_zct1m(i,j,k)*rzm_8)
rxm_8 = -mumum_8 * (F_yct1m(i,j,k)*F_ruw2m(i,j,k)+
$ F_xct1m(i,j,k)*F_zct1m(i,j,k)*rzm_8)
*
* TLM
* ---
rz_8 = F_rvw2(i,j,k)
ry_8 =
% mumum_8* (
% F_xct1m(i,j,k)*F_ruw2 (i,j,k)
% + F_xct1 (i,j,k)*F_ruw2m(i,j,k)
*
% - F_yct1m(i,j,k)*F_zct1m(i,j,k)*rz_8
% - F_yct1m(i,j,k)*F_zct1 (i,j,k)*rzm_8
% - F_yct1 (i,j,k)*F_zct1m(i,j,k)*rzm_8)
% + mumu_8 * (
% F_xct1m(i,j,k)*F_ruw2m(i,j,k)
*
% - F_yct1m(i,j,k)*F_zct1m(i,j,k)*rzm_8)
rx_8 =
% - mumum_8* (
% F_yct1m(i,j,k)*F_ruw2 (i,j,k)
% + F_yct1 (i,j,k)*F_ruw2m(i,j,k)
*
% + F_xct1m(i,j,k)*F_zct1m(i,j,k)*rz_8
% + F_xct1m(i,j,k)*F_zct1 (i,j,k)*rzm_8
% + F_xct1 (i,j,k)*F_zct1m(i,j,k)*rzm_8)
% - mumu_8 * (
% F_yct1m(i,j,k)*F_ruw2m(i,j,k)
*
% + F_xct1m(i,j,k)*F_zct1m(i,j,k)*rzm_8)
*
* Compute components of (r - r~) and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* TRAJECTORY
* ----------
cxm_8 = x_8 - F_xct1m(i,j,k)
cym_8 = y_8 - F_yct1m(i,j,k)
czm_8 = z_8 - F_zct1m(i,j,k)
*
* TLM
* ---
cx_8 = - F_xct1(i,j,k)
cy_8 = - F_yct1(i,j,k)
cz_8 = - F_zct1(i,j,k)
* Find components of Coriolis vector 2 * omg/tau * [k' ^ (r - r~)]
* where geographic unit north vector k' = r_13 I + r_23 J + r_33 K
* Then substract them from (rx, ry, rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if (.not.Cori_cornl_L) then
*
* TRAJECTORY
* ----------
rxm_8 = rxm_8 + ( Grd_rot_8(2,3)*czm_8 - Grd_rot_8(3,3)*cym_8 )*tot_8
rym_8 = rym_8 + ( Grd_rot_8(3,3)*cxm_8 - Grd_rot_8(1,3)*czm_8 )*tot_8
rzm_8 = rzm_8 + ( Grd_rot_8(1,3)*cym_8 - Grd_rot_8(2,3)*cxm_8 )*tot_8
*
* TLM
* ---
rx_8 = rx_8 + ( Grd_rot_8(2,3)*cz_8 - Grd_rot_8(3,3)*cy_8 )*tot_8
ry_8 = ry_8 + ( Grd_rot_8(3,3)*cx_8 - Grd_rot_8(1,3)*cz_8 )*tot_8
rz_8 = rz_8 + ( Grd_rot_8(1,3)*cy_8 - Grd_rot_8(2,3)*cx_8 )*tot_8
*
endif
*
* Compute components of c and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* TRAJECTORY
* ----------
cxm_8 = x_8 + b1ob0_8*F_xct1m(i,j,k)
cym_8 = y_8 + b1ob0_8*F_yct1m(i,j,k)
czm_8 = z_8 + b1ob0_8*F_zct1m(i,j,k)
*
* TLM
* ---
cx_8 = b1ob0_8*F_xct1(i,j,k)
cy_8 = b1ob0_8*F_yct1(i,j,k)
cz_8 = b1ob0_8*F_zct1(i,j,k)
*
* Compute mu and modify (Rx,Ry,Rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* TRAJECTORY
* ----------
mumum_8 = - ( x_8*rxm_8 + y_8*rym_8 + z_8*rzm_8 )
% /( x_8*cxm_8 + y_8*cym_8 + z_8*czm_8 )
rxm_8 = rxm_8 + mumum_8*cxm_8
rym_8 = rym_8 + mumum_8*cym_8
rzm_8 = rzm_8 + mumum_8*czm_8
*
* TLM
* ---
mumu_8 =
% - ( x_8*rx_8 + y_8*ry_8 + z_8*rz_8 )
% /( x_8*cxm_8 + y_8*cym_8 + z_8*czm_8)
% + ( ( x_8*rxm_8 + y_8*rym_8 + z_8*rzm_8)
% *( x_8*cx_8 + y_8*cy_8 + z_8*cz_8 ) )
% /( x_8*cxm_8 + y_8*cym_8 + z_8*czm_8)**2
rx_8 = rx_8 + mumum_8*cx_8 + mumu_8*cxm_8
ry_8 = ry_8 + mumum_8*cy_8 + mumu_8*cym_8
rz_8 = rz_8 + mumum_8*cz_8 + mumu_8*czm_8
*
* Compute advective contributions on G-grid
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* TRAJECTORY
* ----------
F_ruw2m(i,j,k) = x_8*rym_8 - y_8*rxm_8 - F_ruw1m(i,j,k)
F_rvw2m(i,j,k) = rzm_8 - F_rvw1m(i,j,k)
*
* TLM
* ---
F_ruw2(i,j,k) = x_8*ry_8 - y_8*rx_8 - F_ruw1(i,j,k)
F_rvw2(i,j,k) = rz_8 - F_rvw1(i,j,k)
100 continue
!$omp enddo
**********************************************************
* Final form of the RHS of horizontal momentum equations *
**********************************************************
* Prepare the gradient of topography
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
!$omp single
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_fis , LDIST_DIM, l_ni,l_nj, 1 ,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_ruw2m,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_rvw2m,LDIST_DIM, l_ni, l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* TLM
* ---
call rpn_comm_xch_halo( F_ruw2, 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_rvw2, LDIST_DIM, l_ni, l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* CONSTANT
* --------
i0 = 1
in = l_niu
j0 = 1+pil_s
jn = l_nj-pil_n
if (G_lam) then
if (l_west) i0=1+pil_w
if (l_east) in=l_niu-pil_e
endif
j00 = 1
jnn = l_njv
i00 = 1+pil_w
inn = l_ni-pil_e
if (G_lam) then
if (l_south) j00 = 1+pil_s
if (l_north) jnn = l_njv-pil_n
else
if (l_south) j00 = 2
if (l_north) jnn = l_njv-1
endif
!$omp end single
!$omp do
do j = 1, l_nj
do i = 1, l_ni
wij1(i,j) = ( F_fis(i+1,j) - F_fis(i,j) ) / Geomg_hx_8(i)
end do
end do
!$omp enddo
!$omp do
do j = 1, l_njv
do i = 1, l_ni
wij2(i,j) = ( F_fis(i,j+1) - F_fis(i,j) ) *
$ Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
end do
end do
!$omp enddo
*
!$omp do
do k=1,l_nk
* Add advective & topographic contributions to Ru & Rv
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rum(i,j,k) = F_rum(i,j,k) - ccc_8*wij1(i,j) +
$ inuvl_wxxu3_8(i,1)*F_ruw2m(i-1,j,k)
$ + inuvl_wxxu3_8(i,2)*F_ruw2m(i ,j,k)
$ + inuvl_wxxu3_8(i,3)*F_ruw2m(i+1,j,k)
$ + inuvl_wxxu3_8(i,4)*F_ruw2m(i+2,j,k)
*
* TLM
* ---
F_ru(i,j,k) = F_ru(i,j,k) +
$ inuvl_wxxu3_8(i,1)*F_ruw2(i-1,j,k)
$ + inuvl_wxxu3_8(i,2)*F_ruw2(i ,j,k)
$ + inuvl_wxxu3_8(i,3)*F_ruw2(i+1,j,k)
$ + inuvl_wxxu3_8(i,4)*F_ruw2(i+2,j,k)
end do
end do
*
do j= j00, jnn
do i= i00, inn
*
* TRAJECTORY
* ----------
F_rvm(i,j,k) = F_rvm(i,j,k) - ccc_8*wij2(i,j) +
$ inuvl_wyyv3_8(j,1)*F_rvw2m(i,j-1,k)
$ + inuvl_wyyv3_8(j,2)*F_rvw2m(i,j ,k)
$ + inuvl_wyyv3_8(j,3)*F_rvw2m(i,j+1,k)
$ + inuvl_wyyv3_8(j,4)*F_rvw2m(i,j+2,k)
*
* TLM
* ---
F_rv(i,j,k) = F_rv(i,j,k) +
$ inuvl_wyyv3_8(j,1)*F_rvw2(i,j-1,k)
$ + inuvl_wyyv3_8(j,2)*F_rvw2(i,j ,k)
$ + inuvl_wyyv3_8(j,3)*F_rvw2(i,j+1,k)
$ + inuvl_wyyv3_8(j,4)*F_rvw2(i,j+2,k)
end do
end do
if (.not.G_lam) then
if (l_south) then
do i = 1, l_ni
* TRAJECTORY
* ----------
F_rvm(i,1,k) = F_rvm(i,1,k) - ccc_8*wij2(i,1) +
$ inuvl_wyyv3_8(1,2)*F_rvw2m(i,1,k)
$ + inuvl_wyyv3_8(1,3)*F_rvw2m(i,2,k)
$ + inuvl_wyyv3_8(1,4)*F_rvw2m(i,3,k)
*
* TLM
* ---
F_rv(i,1,k) = F_rv(i,1,k) +
$ inuvl_wyyv3_8(1,2)*F_rvw2(i,1,k)
$ + inuvl_wyyv3_8(1,3)*F_rvw2(i,2,k)
$ + inuvl_wyyv3_8(1,4)*F_rvw2(i,3,k)
end do
endif
if (l_north) then
do i = 1, l_ni
* TRAJECTORY
* ----------
F_rvm(i,l_njv,k) = F_rvm(i,l_njv,k) - ccc_8*wij2(i,l_njv) +
$ inuvl_wyyv3_8(l_njv,1)*F_rvw2m(i,l_njv-1,k)
$ + inuvl_wyyv3_8(l_njv,2)*F_rvw2m(i,l_njv ,k)
$ + inuvl_wyyv3_8(l_njv,3)*F_rvw2m(i,l_njv+1,k)
*
* TLM
* ---
F_rv(i,l_njv,k) = F_rv(i,l_njv,k) +
$ inuvl_wyyv3_8(l_njv,1)*F_rvw2(i,l_njv-1,k)
$ + inuvl_wyyv3_8(l_njv,2)*F_rvw2(i,l_njv ,k)
$ + inuvl_wyyv3_8(l_njv,3)*F_rvw2(i,l_njv+1,k)
end do
endif
endif
end do
!$omp enddo
**************************************
* Combination of governing equations *
**************************************
a1_8 = ONE_8/( Dcst_grav_8 * Cstv_tau_8 )
a2_8 = Schm_nonhy_8/( Dcst_grav_8**2 * Cstv_tau_8**2 )
b1_8 = gamma_8/Cstv_tau_8
b2_8 = gamma_8/Cstv_tau_8/Dcst_cappa_8
!$omp single
* Compute the RHS of divergence equation
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* 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
*
!$omp do
do k=1,l_nk
if (G_lam) then
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
*
* TRAJECTORY
* ----------
F_rdm(i,j,k) = ( F_rum(i,j,k) - F_rum(i-1,j,k) )
$ /( Geomg_cy2_8(j)*Geomg_hxu_8(i-1) )
$ + ( F_rvm(i,j,k) - F_rvm(i,j-1,k) )*Geomg_invhsyv_8(j-1)
*
* TLM
* ---
F_rd(i,j,k) = ( F_ru(i,j,k) - F_ru(i-1,j,k) )
$ /( Geomg_cy2_8(j)*Geomg_hxu_8(i-1) )
$ + ( F_rv(i,j,k) - F_rv(i,j-1,k) )*Geomg_invhsyv_8(j-1)
end do
end do
else
* TRAJECTORY
* ----------
call caldiv_2 ( F_rdm(minx,miny,k), F_rum(minx,miny,k),
$ F_rvm(minx,miny,k), LDIST_DIM, 1)
* TLM
* ---
call caldiv_2 ( F_rd(minx,miny,k), F_ru(minx,miny,k),
$ F_rv(minx,miny,k), LDIST_DIM, 1)
endif
* Combination of divergence & continuity equations
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
* TRAJECTORY
* ----------
F_r1m(i,j,k) = F_rdm(i,j,k) - F_rcnm(i,j,k)/Cstv_tau_8
F_wijk1m(i,j,k) = F_r1m(i,j,k)
F_wijk2m(i,j,k) = b2_8*F_rthm(i,j,k)
*
* TLM
* ---
F_r1(i,j,k) = F_rd(i,j,k) - F_rcn(i,j,k)/Cstv_tau_8
F_wijk1(i,j,k) = F_r1(i,j,k)
F_wijk2(i,j,k) = b2_8*F_rth(i,j,k)
*
end do
end do
if (.not. Schm_hydro_L) then
* Combination of equations for vertical motion
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
* TRAJECTORY
* ----------
F_rvvm(i,j,k) = F_rvvm(i,j,k) - F_fis(i,j)/Cstv_tau_8
F_r3m (i,j,k) = a1_8*F_rwm(i,j,k)+ a2_8*F_rvvm(i,j,k)
F_r3pm(i,j,k) = F_r3m(i,j,k) - eps_8*F_rthm(i,j,k)
F_wijk1m(i,j,k) = F_wijk1m(i,j,k) + b1_8*F_r3pm(i,j,k)
F_wijk2m(i,j,k) = F_wijk2m(i,j,k) + b2_8*F_r3m(i,j,k)
* TLM
* ---
C F_rvv(i,j,k) = F_rvv(i,j,k)
F_r3 (i,j,k) = a1_8*F_rw(i,j,k)+ a2_8*F_rvv(i,j,k)
F_r3p(i,j,k) = F_r3(i,j,k) - eps_8*F_rth(i,j,k)
F_wijk1(i,j,k) = F_wijk1(i,j,k) + b1_8*F_r3p(i,j,k)
F_wijk2(i,j,k) = F_wijk2(i,j,k) + b2_8*F_r3(i,j,k)
end do
end do
endif
*
end do
!$omp enddo
****************************************
* The linear RHS of Helmholtz equation *
****************************************
*
!$omp do
do k=1,l_nk
if ( k .eq. 1 ) then
a2_8 = QUARTER_8*Geomg_hz_8(k)
b2_8 = HALF_8*Geomg_z_8(k)
b3_8 = HALF_8*Geomg_z_8(k+1)
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
* TRAJECTORY
* ----------
F_rhellm(i,j,k) = a2_8*( F_wijk1m(i,j,k) + F_wijk1m(i,j,k+1) )
% - b2_8*F_wijk2m(i,j,k) - b3_8*F_wijk2m(i,j,k+1)
*
* TLM
* ---
F_rhell(i,j,k) = a2_8*( F_wijk1(i,j,k) + F_wijk1(i,j,k+1) )
% - b2_8*F_wijk2(i,j,k) - b3_8*F_wijk2(i,j,k+1)
end do
end do
elseif( k .eq. l_nk ) then
a1_8 = QUARTER_8*Geomg_hz_8(k-1)
b1_8 = HALF_8*Geomg_z_8(k-1)
b2_8 = HALF_8*Geomg_z_8(k)
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
* TRAJECTORY
* ----------
F_rhellm(i,j,k) = a1_8*( F_wijk1m(i,j,k-1) + F_wijk1m(i,j,k) )
% + b1_8*F_wijk2m(i,j,k-1) + b2_8*F_wijk2m(i,j,k)
*
* TLM
* ---
F_rhell(i,j,k) = a1_8*( F_wijk1(i,j,k-1) + F_wijk1(i,j,k) )
% + b1_8*F_wijk2(i,j,k-1) + b2_8*F_wijk2(i,j,k)
end do
end do
else
a1_8 = QUARTER_8*Geomg_hz_8(k-1)
a2_8 = QUARTER_8*Geomg_hz_8(k)
b1_8 = HALF_8*Geomg_z_8(k-1)
b3_8 = HALF_8*Geomg_z_8(k+1)
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
* TRAJECTORY
* ----------
F_rhellm(i,j,k) = a1_8*( F_wijk1m(i,j,k-1) + F_wijk1m(i,j,k) )
% + a2_8*( F_wijk1m(i,j,k) + F_wijk1m(i,j,k+1) )
% + b1_8*F_wijk2m(i,j,k-1) - b3_8*F_wijk2m(i,j,k+1)
*
* TLM
* ---
F_rhell(i,j,k) = a1_8*( F_wijk1(i,j,k-1) + F_wijk1(i,j,k) )
% + a2_8*( F_wijk1(i,j,k) + F_wijk1(i,j,k+1) )
% + b1_8*F_wijk2(i,j,k-1) - b3_8*F_wijk2(i,j,k+1)
end do
end do
endif
end do
!$omp enddo
!$omp end parallel
*
* __________________________________________________________________
*
return
end