!-------------------------------------- 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 nlip_2_tl - TLM of nlip_2
*
#include "model_macros_f.h"
*
subroutine nlip_2_tl ( F_nu, F_nv, F_n1, F_nth, F_n3, F_n3p, 1,1
$ F_rheln, F_rhell, F_tpt0, F_tplt0, F_pipt0,
$ F_ncn, F_st0, F_qt0, F_fipt0, F_fis,
$ F_ut0, F_vt0, F_mut0 ,F_multx,
$ F_wijk1, F_wijk2,
*
$ F_num, F_nvm, F_n1m, F_nthm, F_n3m, F_n3pm,
$ F_rhelnm,F_rhellm,F_tpt0m,F_tplt0m,F_pipt0m,
$ F_ncnm, F_st0m, F_qt0m, F_fipt0m,
$ F_ut0m, F_vt0m, F_mut0m,F_multxm,
$ F_wijk1m,F_wijk2m,
*
$ DIST_DIM, Nk )
*
implicit none
*
integer DIST_DIM, Nk
real F_nu (DIST_SHAPE,Nk), F_nv (DIST_SHAPE,Nk),
% F_n1 (DIST_SHAPE,Nk), F_nth (DIST_SHAPE,Nk),
% F_n3 (DIST_SHAPE,Nk), F_n3p (DIST_SHAPE,Nk),
% F_rheln(DIST_SHAPE,Nk), F_rhell(DIST_SHAPE,Nk),
% F_tpt0 (DIST_SHAPE,Nk), F_tplt0(DIST_SHAPE,Nk),
% F_pipt0(DIST_SHAPE,Nk), F_ncn (DIST_SHAPE,Nk),
% F_st0 (DIST_SHAPE) , F_qt0 (DIST_SHAPE,Nk),
% F_fipt0(DIST_SHAPE,Nk), F_fis (DIST_SHAPE) ,
% F_ut0 (DIST_SHAPE,Nk), F_vt0 (DIST_SHAPE,Nk),
% F_mut0 (DIST_SHAPE,Nk), F_multx(DIST_SHAPE,Nk),
% F_wijk1(DIST_SHAPE,Nk), F_wijk2(DIST_SHAPE,Nk)
*
real F_num (DIST_SHAPE,Nk), F_nvm (DIST_SHAPE,Nk),
% F_n1m (DIST_SHAPE,Nk), F_nthm (DIST_SHAPE,Nk),
% F_n3m (DIST_SHAPE,Nk), F_n3pm (DIST_SHAPE,Nk),
% F_rhelnm(DIST_SHAPE,Nk), F_rhellm(DIST_SHAPE,Nk),
% F_tpt0m (DIST_SHAPE,Nk), F_tplt0m(DIST_SHAPE,Nk),
% F_pipt0m(DIST_SHAPE,Nk), F_ncnm (DIST_SHAPE,Nk),
% F_st0m (DIST_SHAPE) , F_qt0m (DIST_SHAPE,Nk),
% F_fipt0m(DIST_SHAPE,Nk),
% F_ut0m (DIST_SHAPE,Nk), F_vt0m (DIST_SHAPE,Nk),
% F_mut0m (DIST_SHAPE,Nk), F_multxm(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_30 - Edouard S. - remove pi' at the top (pptt0)
* v2_31 - Tanguay M. - adapt for vertical hybrid coordinate and LAM version
* v3_00 - Tanguay M. - adapt to restructured nlip_2
* v3_03 - Tanguay M. - Adjoint Lam and NoHyd configuration
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
*
*object
* see id section
* --------------------------------------------------------
* REMARK: INPUT TRAJ:F_tpt0m, F_pipt0m, F_qt0m, F_st0m
* F_tplt0m, F_ut0m, F_vt0m, F_rhellm
* F_fipt0m, F_mut0m, F_multxm (NoHyd)
* --------------------------------------------------------
*
*arguments
* see documentation of appropriate comdecks
*
*implicits
#include "glb_ld.cdk"
*
integer i01, in1, j01, jn1, nij, i02, in2, j02, jn2
*
* Prepare the nonlinear perturbation q" of log hydro pressure
* and the "relative" geopotential ( phi' + phis ) for gradient
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i01=1
in1=l_ni
j01=1
jn1=l_nj
i02=1
in2=l_ni
j02=1
jn2=l_nj
if (G_lam) then
if (l_west) i01=1+pil_w -1
if (l_east) in1=l_ni-pil_e +1
if (l_south)j01=1+pil_s -1
if (l_north)jn1=l_nj-pil_n +1
if (l_west) i02=1+pil_w
if (l_east) in2=l_ni-pil_e
if (l_south)j02=1+pil_s
if (l_north)jn2=l_nj-pil_n
endif
*
call nlip_2_2_tl ( F_nu, F_nv, F_n1, F_nth, F_n3, F_n3p,
$ F_rheln, F_rhell, F_tpt0, F_tplt0, F_pipt0,
$ F_ncn, F_st0, F_qt0, F_fipt0, F_fis,
$ F_ut0, F_vt0, F_mut0 ,F_multx,
$ F_wijk1, F_wijk2,
*
$ F_num, F_nvm, F_n1m, F_nthm, F_n3m, F_n3pm,
$ F_rhelnm,F_rhellm,F_tpt0m,F_tplt0m,F_pipt0m,
$ F_ncnm, F_st0m, F_qt0m, F_fipt0m,
$ F_ut0m, F_vt0m, F_mut0m,F_multxm,
$ F_wijk1m,F_wijk2m,
*
$ DIST_DIM, Nk,
$ i01,j01,in1,jn1,i02,j02,in2,jn2 )
*
return
end
*
! 2nd stage added for OpenMP
*
subroutine nlip_2_2_tl ( F_nu, F_nv, F_n1, F_nth, F_n3, F_n3p, 1,2
$ F_rheln, F_rhell, F_tpt0, F_tplt0, F_pipt0,
$ F_ncn, F_st0, F_qt0, F_fipt0, F_fis,
$ F_ut0, F_vt0, F_mut0 ,F_multx,
$ F_wijk1, F_wijk2,
*
$ F_num, F_nvm, F_n1m, F_nthm, F_n3m, F_n3pm,
$ F_rhelnm,F_rhellm,F_tpt0m,F_tplt0m,F_pipt0m,
$ F_ncnm, F_st0m, F_qt0m, F_fipt0m,
$ F_ut0m, F_vt0m, F_mut0m,F_multxm,
$ F_wijk1m,F_wijk2m,
*
$ DIST_DIM, Nk,
$ i01,j01,in1,jn1,i02,j02,in2,jn2 )
*
implicit none
*
integer DIST_DIM, Nk, i01,j01,in1,jn1,i02,j02,in2,jn2
real F_nu (DIST_SHAPE,Nk), F_nv (DIST_SHAPE,Nk),
% F_n1 (DIST_SHAPE,Nk), F_nth (DIST_SHAPE,Nk),
% F_n3 (DIST_SHAPE,Nk), F_n3p (DIST_SHAPE,Nk),
% F_rheln(DIST_SHAPE,Nk), F_rhell(DIST_SHAPE,Nk),
% F_tpt0 (DIST_SHAPE,Nk), F_tplt0(DIST_SHAPE,Nk),
% F_pipt0(DIST_SHAPE,Nk), F_ncn (DIST_SHAPE,Nk),
% F_st0 (DIST_SHAPE) , F_qt0 (DIST_SHAPE,Nk),
% F_fipt0(DIST_SHAPE,Nk), F_fis (DIST_SHAPE) ,
% F_ut0 (DIST_SHAPE,Nk), F_vt0 (DIST_SHAPE,Nk),
% F_mut0 (DIST_SHAPE,Nk), F_multx(DIST_SHAPE,Nk),
% F_wijk1(DIST_SHAPE,Nk), F_wijk2(DIST_SHAPE,Nk)
*
real F_num (DIST_SHAPE,Nk), F_nvm (DIST_SHAPE,Nk),
% F_n1m (DIST_SHAPE,Nk), F_nthm (DIST_SHAPE,Nk),
% F_n3m (DIST_SHAPE,Nk), F_n3pm (DIST_SHAPE,Nk),
% F_rhelnm(DIST_SHAPE,Nk), F_rhellm(DIST_SHAPE,Nk),
% F_tpt0m (DIST_SHAPE,Nk), F_tplt0m(DIST_SHAPE,Nk),
% F_pipt0m(DIST_SHAPE,Nk), F_ncnm (DIST_SHAPE,Nk),
% F_st0m (DIST_SHAPE) , F_qt0m (DIST_SHAPE,Nk),
% F_fipt0m(DIST_SHAPE,Nk),
% F_ut0m (DIST_SHAPE,Nk), F_vt0m (DIST_SHAPE,Nk),
% F_mut0m (DIST_SHAPE,Nk), F_multxm(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_30 - Edouard S. - remove pi' at the top (pptt0)
* v2_31 - Tanguay M. - adapt for vertical hybrid coordinate and LAM version
* v3_00 - Tanguay M. - adapt to restructured nlip_2
* 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_tpt0m, F_pipt0m, F_qt0m, F_st0m
* F_tplt0m, F_ut0m, F_vt0m, F_rhellm
* F_fipt0m, F_mut0m, F_multxm (NoHyd)
* --------------------------------------------------------
*
*arguments
* see documentation of appropriate comdecks
*
*implicits
#include "glb_ld.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "cori.cdk"
#include "schm.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
#include "ptopo.cdk"
*
integer i, j, k, i00, inn, j00, jnn, i0, in, j0, jn, nij
real wk2(DIST_SHAPE), w1, w2, w3, q1
*
real*8 ONE_8, HALF_8, QUARTER_8
parameter ( ONE_8=1.0, HALF_8=.5, QUARTER_8=.25 )
*
real*8 eps_8, gamma_8
real*8 p1_8,p2_8,p3_8,p4_8,p5_8,p6_8,p7_8,t1_8,t2_8,t3_8,t4_8
*
real*8 t1m_8
real w1m,w2m,w3m,wk2m(DIST_SHAPE)
*
real*8, dimension(i01:in1,j01:jn1) :: xlogm_8, ylogm_8, invm_8
real*8, dimension(i02:in2,j02:jn2) :: yexp2m_8, xlog2m_8, ylog2m_8, inv2m_8
*
* --------------------------------------------------------------------
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_tpt0m ,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_qt0m ,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_mut0m ,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
endif
if (Cori_cornl_L) then
call rpn_comm_xch_halo( F_ut0m ,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_vt0m ,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_tpt0 , 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_qt0 , 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_mut0 ,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
endif
*
if (Cori_cornl_L) then
call rpn_comm_xch_halo( F_ut0 ,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_vt0 ,LDIST_DIM,l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
endif
*
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
p1_8 = Dcst_rayt_8*Dcst_rayt_8
p2_8 = ONE_8 / Cstv_tau_8
p3_8 = ONE_8 / p1_8
p4_8 = Dcst_rgasd_8 / p1_8
p5_8 = ONE_8 / Cstv_tstr_8
p6_8 = gamma_8 / Cstv_tau_8
p7_8 = p6_8 / Dcst_cappa_8
*
q1 = ONE_8 / Cstv_tau_8
*
!$omp parallel private(xlogm_8, ylogm_8, invm_8,
!$omp$ xlog2m_8,ylog2m_8,inv2m_8,
!$omp$ i0,in,j0,jn,i00,j00,inn,jnn,
!$omp$ wk2m,wk2,w1m,w2m,w3m,
!$omp$ w1,w2,w3,t1_8,t2_8,t3_8,t4_8,t1m_8)
*
i0=i01
j0=j01
in=in1
jn=jn1
*
nij = (in - i0 + 1)*(jn - j0 + 1)
*
!$omp do
do k=1,l_nk
t1_8 = ONE_8/Geomg_z_8(k)
*
do j= j0, jn
do i= i0, in
xlogm_8(i,j) = ONE_8 + F_pipt0m(i,j,k)*t1_8
end do
call vlog (ylogm_8(i0,j), xlogm_8(i0,j), (in-i0+1))
call vrec ( invm_8(i0,j), xlogm_8(i0,j), (in-i0+1))
end do
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk1m(i,j,k) = ylogm_8(i,j) - ( Geomg_pib(k)* F_st0m(i,j) )*t1_8
*
* TLM
* ---
F_wijk1(i,j,k) = ( F_pipt0(i,j,k)*t1_8 ) * invm_8(i,j) - ( Geomg_pib(k) * F_st0(i,j) )*t1_8
*
enddo
enddo
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
* TRAJECTORY
* ----------
F_wijk2m(i,j,k)= F_fipt0m(i,j,k) + F_fis(i,j)
*
* TLM
* ---
F_wijk2(i,j,k) = F_fipt0 (i,j,k)
enddo
enddo
endif
*
enddo
!$omp enddo
************************************************************
* The nonlinear deviation of horizontal momentum equations *
************************************************************
*
!$omp single
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_wijk1m,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_wijk2m,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_wijk1, 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_wijk2,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
endif
*
!$omp end single
*
!$omp do
do 100 k=1,l_nk
*
* Compute Nu for hydrostatic version
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
w1m = ( 1. - intuv_c0xxu_8(i) ) * F_tpt0m(i ,j,k)
% + intuv_c0xxu_8(i) * F_tpt0m(i+1,j,k)
w2m = ( F_qt0m(i+1,j,k) - F_qt0m(i,j,k) ) * Geomg_invhx_8(i)
w3m = ( F_wijk1m(i+1,j,k) - F_wijk1m(i,j,k) ) * Geomg_invhx_8(i)
F_num(i,j,k) = p4_8 * ( w1m*w2m + Cstv_tstr_8*w3m )
*
* TLM
* ---
w1 = ( 1. - intuv_c0xxu_8(i) ) * F_tpt0(i ,j,k)
% + intuv_c0xxu_8(i) * F_tpt0(i+1,j,k)
w2 = ( F_qt0(i+1,j,k) - F_qt0(i,j,k) ) * Geomg_invhx_8(i)
w3 = ( F_wijk1(i+1,j,k) - F_wijk1(i,j,k) ) * Geomg_invhx_8(i)
F_nu(i,j,k) = p4_8 * ( w1m*w2 + w1*w2m + Cstv_tstr_8*w3 )
*
end do
end do
*
if (Cori_cornl_L) then
* Set indices for calculating wk2
i00 = minx
inn = maxx
j00 = 1+pil_s
jnn = l_njv
if (G_lam) then
if (l_west) i00 = 1+pil_w -2
if (l_east) inn = l_niu-pil_e +3
if (l_north)jnn = l_njv-pil_n +1
else
if (l_south) j00 = 3
if (l_north) jnn = l_njv-1
endif
*
do j = j00, jnn
do i = i00, inn
* TRAJECTORY
* ----------
wk2m(i,j) = inuvl_wyvy3_8(j,1) * F_vt0m(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * F_vt0m(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * F_vt0m(i,j ,k)
% + inuvl_wyvy3_8(j,4) * F_vt0m(i,j+1,k)
* TLM
* ---
wk2(i,j) = inuvl_wyvy3_8(j,1) * F_vt0(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * F_vt0(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * F_vt0(i,j ,k)
% + inuvl_wyvy3_8(j,4) * F_vt0(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_vt0m(i,j00-2,k)
% + inuvl_wyvy3_8(j00-2,4)*F_vt0m(i,j00-1,k)
wk2m(i,j00-1)= inuvl_wyvy3_8(j00-1,2)*F_vt0m(i,j00-2,k)
% + inuvl_wyvy3_8(j00-1,3)*F_vt0m(i,j00-1,k)
% + inuvl_wyvy3_8(j00-1,4)*F_vt0m(i,j00 ,k)
* TLM
* ---
wk2(i,j00-2)= inuvl_wyvy3_8(j00-2,3)*F_vt0(i,j00-2,k)
% + inuvl_wyvy3_8(j00-2,4)*F_vt0(i,j00-1,k)
wk2(i,j00-1)= inuvl_wyvy3_8(j00-1,2)*F_vt0(i,j00-2,k)
% + inuvl_wyvy3_8(j00-1,3)*F_vt0(i,j00-1,k)
% + inuvl_wyvy3_8(j00-1,4)*F_vt0(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_vt0m(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+2,2)*F_vt0m(i,jnn+1,k)
wk2m(i,jnn+1)= inuvl_wyvy3_8(jnn+1,1)*F_vt0m(i,jnn-1,k)
% + inuvl_wyvy3_8(jnn+1,2)*F_vt0m(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+1,3)*F_vt0m(i,jnn+1,k)
* TLM
* ---
wk2(i,jnn+2)= inuvl_wyvy3_8(jnn+2,1)*F_vt0(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+2,2)*F_vt0(i,jnn+1,k)
wk2(i,jnn+1)= inuvl_wyvy3_8(jnn+1,1)*F_vt0(i,jnn-1,k)
% + inuvl_wyvy3_8(jnn+1,2)*F_vt0(i,jnn ,k)
% + inuvl_wyvy3_8(jnn+1,3)*F_vt0(i,jnn+1,k)
end do
endif
endif
*
do j= j0, jn
do i= i0, in
* TRAJECTORY
* ----------
F_num(i,j,k) = F_num(i,j,k) - 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))
*
* TLM
* ---
F_nu(i,j,k) = F_nu(i,j,k) - 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))
end do
end do
endif
*
* Compute Nv for hydrostatic version
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i0 = 1+pil_w
in = l_ni-pil_e
j0 = 1
jn = l_njv
if (G_lam) then
if (l_south) j0=1+pil_s
if (l_north) jn=l_njv-pil_n
endif
do j= j0, jn
t1_8 = Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
do i= i0, in
*
* TRAJECTORY
* ----------
w1m = ( 1. - intuv_c0yyv_8(j) ) * F_tpt0m(i,j ,k)
% + intuv_c0yyv_8(j) * F_tpt0m(i,j+1,k)
w2m = (F_qt0m (i,j+1,k) - F_qt0m(i,j,k)) * t1_8
w3m = (F_wijk1m(i,j+1,k)-F_wijk1m(i,j,k)) * t1_8
F_nvm(i,j,k) = p4_8 * ( w1m*w2m + Cstv_tstr_8*w3m )
*
* TLM
* ---
w1 = ( 1. - intuv_c0yyv_8(j) ) * F_tpt0(i,j ,k)
% + intuv_c0yyv_8(j) * F_tpt0(i,j+1,k)
w2 = (F_qt0 (i,j+1,k) - F_qt0(i,j,k)) * t1_8
w3 = (F_wijk1(i,j+1,k)-F_wijk1(i,j,k)) * t1_8
F_nv(i,j,k) = p4_8 * ( w1m*w2 + w1*w2m + Cstv_tstr_8*w3 )
*
end do
end do
*
if (Cori_cornl_L) then
* Set indices for calculating wk2
j00 = miny
jnn = maxy
i00 = 1+pil_w
inn = l_niu
if (G_lam) then
if (l_south) j00=1+pil_s-2
if (l_north) jnn=l_njv-pil_n+3
if (l_east) inn = l_niu-pil_e +1
endif
*
do j = j00, jnn
do i = i00, inn
* TRAJECTORY
* ----------
wk2m(i,j) = inuvl_wxux3_8(i,1)*F_ut0m(i-2,j,k)
% + inuvl_wxux3_8(i,2)*F_ut0m(i-1,j,k)
% + inuvl_wxux3_8(i,3)*F_ut0m(i ,j,k)
% + inuvl_wxux3_8(i,4)*F_ut0m(i+1,j,k)
*
* TLM
* ---
wk2(i,j) = inuvl_wxux3_8(i,1)*F_ut0(i-2,j,k)
% + inuvl_wxux3_8(i,2)*F_ut0(i-1,j,k)
% + inuvl_wxux3_8(i,3)*F_ut0(i ,j,k)
% + inuvl_wxux3_8(i,4)*F_ut0(i+1,j,k)
end do
end do
*
* Set indices for calculating Nv
if (.not.G_lam) then
if (l_south) j0 = 2
if (l_north) jn = l_njv-1
endif
do j = j0, jn
do i = i0, in
* TRAJECTORY
* ----------
F_nvm(i,j,k) = F_nvm(i,j,k) + 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))
*
* TLM
* ---
F_nv(i,j,k) = F_nv(i,j,k) + 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))
end do
end do
*
if (.not.G_lam) then
if (l_south) then
do i = i0, in
* TRAJECTORY
* ----------
F_nvm(i,1,k)= F_nvm(i,1,k) + 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))
*
* TLM
* ---
F_nv(i,1,k) = F_nv(i,1,k) + 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))
end do
endif
*
if (l_north) then
do i = i0, in
* TRAJECTORY
* ----------
F_nvm(i,l_njv,k)=F_nvm(i,l_njv,k)+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) )
*
* TLM
* ---
F_nv(i,l_njv,k)=F_nv(i,l_njv,k)+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) )
end do
endif
endif
endif
*
if (.not. Schm_hydro_L) then
*
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
i00 = 1+pil_w
inn = l_ni-pil_e
j00 = 1
jnn = l_njv
if (G_lam) then
if (l_south) j00 = 1+pil_s
if (l_north) jnn = l_njv-pil_n
endif
*
* Add nonhydrostatic contributions to Nu
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
w1m = ( 1. - intuv_c0xxu_8(i) ) * F_mut0m(i ,j,k)
% + intuv_c0xxu_8(i) * F_mut0m(i+1,j,k)
w2m = ( F_wijk2m(i+1,j,k) -F_wijk2m (i,j,k) ) * Geomg_invhx_8(i)
F_num(i,j,k) = F_num(i,j,k) + p3_8*w1m*w2m
*
* TLM
* ---
w1 = ( 1. - intuv_c0xxu_8(i) ) * F_mut0(i ,j,k)
% + intuv_c0xxu_8(i) * F_mut0(i+1,j,k)
w2 = ( F_wijk2(i+1,j,k) -F_wijk2 (i,j,k) ) * Geomg_invhx_8(i)
F_nu(i,j,k) = F_nu(i,j,k) + p3_8*(w1m*w2 + w1*w2m)
*
end do
end do
*
* Add nonhydrostatic contributions to Nv
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j00, jnn
do i= i00, inn
*
* TRAJECTORY
* ----------
w1m = ( 1. - intuv_c0yyv_8(j) ) * F_mut0m(i,j ,k)
% + intuv_c0yyv_8(j) * F_mut0m(i,j+1,k)
w2m = (F_wijk2m (i,j+1,k) - F_wijk2m(i,j,k) )
% *Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
F_nvm(i,j,k) = F_nvm(i,j,k) + p3_8*w1m*w2m
*
* TLM
* ---
w1 = ( 1. - intuv_c0yyv_8(j) ) * F_mut0(i,j ,k)
% + intuv_c0yyv_8(j) * F_mut0(i,j+1,k)
w2 = (F_wijk2 (i,j+1,k) - F_wijk2(i,j,k) )
% *Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
F_nv(i,j,k) = F_nv(i,j,k) + p3_8*(w1m*w2 + w1*w2m)
end do
end do
endif
*
if (k.eq.1) then
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_west) i0 = 1+pil_w
if (l_east) in = l_ni-pil_e
if (l_south) j0 = 1+pil_s
if (l_north) jn = l_nj-pil_n
endif
nij = (in - i0 +1)*(jn - j0 +1)
do j = j0, jn
do i = i0, in
yexp2m_8(i,j) = F_st0m(i,j)
end do
call vexp ( yexp2m_8(i0,j), yexp2m_8(i0,j), (in-i0+1) )
end do
endif
*
100 continue
!$omp enddo
* For LAM, set Nu,Nv 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_num(pil_w,j,k) = 0.
*
* TLM
* ---
F_nu(pil_w,j,k) = 0.
end do
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_num(l_ni-pil_e,j,k) = 0.
*
* TLM
* ---
F_nu(l_ni-pil_e,j,k) = 0.
end do
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_nvm(i,pil_s,k) = 0.
*
* TLM
* ---
F_nv(i,pil_s,k) = 0.
end do
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_nvm(i,l_nj-pil_n,k) = 0.
*
* TLM
* ---
F_nv(i,l_nj-pil_n,k) = 0.
end do
enddo
!$omp enddo
endif
endif
*
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_west) i0 = 1+pil_w
if (l_east) in = l_ni-pil_e
if (l_south) j0 = 1+pil_s
if (l_north) jn = l_nj-pil_n
endif
*
nij = (in - i0 +1)*(jn - j0 +1)
*
**************************************
* Combination of governing equations *
**************************************
*
* compute Ncn
* ~~~~~~~~~~~
!$omp do
do k = 1, l_nk
*
do j = j0, jn
do i = i0, in
xlog2m_8(i,j) = 1. + Geomg_dpba(k) * (yexp2m_8(i,j) - 1.0)
end do
call vlog(ylog2m_8(i0,j), xlog2m_8(i0,j), (in-i0+1))
call vrec( inv2m_8(i0,j), xlog2m_8(i0,j), (in-i0+1))
end do
*
do j = j0, jn
do i = i0, in
* TRAJECTORY
* ----------
w1m= ylog2m_8(i,j)
w2m= Geomg_dpib(k) * F_st0m(i,j)
F_ncnm(i,j,k) = q1 * ( w1m - w2m )
*
* TLM
* ---
w1 = ( Geomg_dpba(k) * (yexp2m_8(i,j)*F_st0(i,j)) ) * inv2m_8(i,j)
w2 = Geomg_dpib(k) * F_st0(i,j)
F_ncn(i,j,k) = q1 * ( w1 - w2 )
enddo
enddo
*
enddo
!$omp enddo
*
!$omp single
*
* Compute the nonlinear deviation of horizontal divergence
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_num, 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_nvm, 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_nu, 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_nv, 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= j0,jn
do i= i0,in
*
* TRAJECTORY
* ----------
F_n1m(i,j,k) = (F_num(i,j,k) - F_num(i-1,j,k)) /( Geomg_cy2_8(j)*Geomg_hxu_8(i-1) )
$ + (F_nvm(i,j,k) - F_nvm(i,j-1,k)) * Geomg_invhsyv_8(j-1)
*
* TLM
* ---
F_n1(i,j,k) = (F_nu(i,j,k) - F_nu(i-1,j,k) ) /( Geomg_cy2_8(j)*Geomg_hxu_8(i-1) )
$ + (F_nv(i,j,k) - F_nv(i,j-1,k) ) * Geomg_invhsyv_8(j-1)
*
end do
end do
else
*
* TRAJECTORY
* ----------
call caldiv_2 ( F_n1m(minx,miny,k), F_num(minx,miny,k),
$ F_nvm(minx,miny,k), LDIST_DIM, 1 )
*
* TLM
* ---
call caldiv_2 ( F_n1(minx,miny,k), F_nu(minx,miny,k),
$ F_nv(minx,miny,k), LDIST_DIM, 1 )
endif
*
do j= j0, jn
do i= i0, in
xlog2m_8(i,j) = ONE_8+F_tpt0m(i,j,k)*p5_8
end do
call vlog ( ylog2m_8(i0,j), xlog2m_8(i0,j), (in-i0+1) )
call vrec ( inv2m_8(i0,j), xlog2m_8(i0,j), (in-i0+1) )
end do
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
t1m_8 = ylog2m_8(i,j)-F_tplt0m(i,j,k)*p5_8
F_nthm(i,j,k) = (-Dcst_cappa_8*F_wijk1m(i,j,k)+t1m_8)*p2_8
F_wijk1m(i,j,k) = F_n1m(i,j,k)- q1 * F_ncnm(i,j,k)
F_wijk2m(i,j,k) = p7_8*F_nthm(i,j,k)
*
* TLM
* ---
t1_8 = (F_tpt0 (i,j,k)*p5_8) * inv2m_8(i,j)
% -F_tplt0(i,j,k)*p5_8
F_nth(i,j,k) =(-Dcst_cappa_8*F_wijk1(i,j,k)+t1_8)*p2_8
F_wijk1(i,j,k) = F_n1(i,j,k)- q1 * F_ncn(i,j,k)
F_wijk2(i,j,k) = p7_8*F_nth(i,j,k)
end do
end do
*
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_n3m (i,j,k) = ( F_multxm(i,j,k) - F_mut0m(i,j,k) )*p2_8
F_n3pm(i,j,k) = F_n3m(i,j,k) - eps_8*F_nthm(i,j,k)
F_wijk1m(i,j,k) = F_wijk1m(i,j,k) + p6_8*F_n3pm(i,j,k)
F_wijk2m(i,j,k) = F_wijk2m(i,j,k) + p7_8*F_n3m (i,j,k)
*
* TLM
* ---
F_n3 (i,j,k) = ( F_multx(i,j,k) - F_mut0(i,j,k) )*p2_8
F_n3p(i,j,k) = F_n3(i,j,k) - eps_8*F_nth(i,j,k)
F_wijk1(i,j,k) = F_wijk1(i,j,k) + p6_8*F_n3p(i,j,k)
F_wijk2(i,j,k) = F_wijk2(i,j,k) + p7_8*F_n3 (i,j,k)
end do
end do
endif
*
end do
!$omp enddo
*
***********************************************
* The RHS of the nonlinear Helmholtz equation *
***********************************************
*
!$omp do
do 300 k=1,l_nk
*
if ( k .eq. 1 ) then
*
t1_8 = QUARTER_8*Geomg_hz_8(k)
t3_8 = HALF_8*Geomg_z_8(k)
t4_8 = HALF_8*Geomg_z_8(k+1)
*
do j= j0, jn
do i= i0, in
* TRAJECTORY
* ----------
F_rhelnm(i,j,k) = p1_8 * (F_rhellm(i,j,k)
$ - t1_8 *( F_wijk1m(i,j,k) + F_wijk1m(i,j,k+1) )
$ + t3_8 *F_wijk2m(i,j,k) + t4_8*F_wijk2m(i,j,k+1))
*
* TLM
* ---
F_rheln(i,j,k) = p1_8 * (F_rhell(i,j,k)
$ - t1_8 *( F_wijk1(i,j,k) + F_wijk1(i,j,k+1) )
$ + t3_8 *F_wijk2(i,j,k) + t4_8*F_wijk2(i,j,k+1))
*
end do
end do
*
elseif ( k .eq. l_nk ) then
*
t1_8 = QUARTER_8*Geomg_hz_8(k-1)
t3_8 = HALF_8*Geomg_z_8(k-1)
t4_8 = HALF_8*Geomg_z_8(k)
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rhelnm(i,j,k) = p1_8 * (F_rhellm(i,j,k)
$ - t1_8 *( F_wijk1m(i,j,k-1) + F_wijk1m(i,j,k) )
$ - t3_8 *F_wijk2m(i,j,k-1) - t4_8*F_wijk2m(i,j,k))
*
* TLM
* ---
F_rheln(i,j,k) = p1_8 * (F_rhell(i,j,k)
$ - t1_8 *( F_wijk1(i,j,k-1) + F_wijk1(i,j,k) )
$ - t3_8 *F_wijk2(i,j,k-1) - t4_8*F_wijk2(i,j,k))
end do
end do
*
else
*
t1_8 = QUARTER_8*Geomg_hz_8(k-1)
t2_8 = QUARTER_8*Geomg_hz_8(k)
t3_8 = HALF_8*Geomg_z_8(k-1)
t4_8 = HALF_8*Geomg_z_8(k+1)
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_rhelnm(i,j,k) = p1_8 * (F_rhellm(i,j,k)
$ - t1_8 *( F_wijk1m(i,j,k-1) + F_wijk1m(i,j,k ) )
$ - t2_8 *( F_wijk1m(i,j,k ) + F_wijk1m(i,j,k+1) )
$ - t3_8 *F_wijk2m(i,j,k-1) + t4_8*F_wijk2m(i,j,k+1))
*
* TLM
* ---
F_rheln(i,j,k) = p1_8 * (F_rhell(i,j,k)
$ - t1_8 *( F_wijk1(i,j,k-1) + F_wijk1(i,j,k ) )
$ - t2_8 *( F_wijk1(i,j,k ) + F_wijk1(i,j,k+1) )
$ - t3_8 *F_wijk2(i,j,k-1) + t4_8*F_wijk2(i,j,k+1))
end do
end do
*
endif
300 continue
!$omp enddo
!$omp end parallel
*
* __________________________________________________________________
*
return
end