!-------------------------------------- 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 bacp_2_tl - TLM of bacp_2
*
#include "model_macros_f.h"
*
subroutine bacp_2_tl 1,1
$ ( F_itr ,F_itnlh, F_st0 ,F_pipt0 ,
$ F_qt0 ,F_fit0 , F_fipt0 ,F_fis ,F_tt0 ,
$ F_tpt0 ,F_tplt0, F_ut0 ,F_vt0 ,F_psdt0 ,
$ F_tdt0 ,F_qpt0 , F_wt0 ,
$ F_mut0 ,F_multx, F_gptx ,F_gxtx ,
$ F_ru ,F_rv , F_rth ,F_r3 ,F_r3p ,
$ F_rvv ,F_rcn , F_nu ,F_nv ,
$ F_nth ,F_n3 , F_n3p ,
$ F_ncn ,F_wijk0, F_wijk1 ,
*
$ F_st0m ,F_pipt0m,
$ F_qt0m ,F_fit0m ,F_fipt0m, F_tt0m ,
$ F_tpt0m,F_tplt0m,F_ut0m ,F_vt0m ,F_psdt0m,
$ F_tdt0m,F_qpt0m ,F_wt0m ,
$ F_mut0m,F_multxm,F_gptxm ,F_gxtxm ,
$ F_rum ,F_rvm ,F_rthm ,F_r3m ,F_r3pm ,
$ F_rvvm ,F_rcnm ,F_num ,F_nvm ,
$ F_nthm ,F_n3m ,F_n3pm ,
$ F_ncnm ,F_wijk0m,F_wijk1m,
*
$ DIST_DIM, Nk )
*
implicit none
*
integer F_itr, F_itnlh, DIST_DIM, Nk
real F_st0 (DIST_SHAPE) ,
% F_pipt0(DIST_SHAPE,Nk) , F_qt0 (DIST_SHAPE,Nk) ,
% F_fit0 (DIST_SHAPE,Nk) , F_fipt0(DIST_SHAPE,Nk) ,
% F_fis (DIST_SHAPE) , F_tt0 (DIST_SHAPE,Nk) ,
% F_tpt0 (DIST_SHAPE,Nk) , F_tplt0(DIST_SHAPE,Nk) ,
% F_ut0 (DIST_SHAPE,Nk) , F_vt0 (DIST_SHAPE,Nk) ,
% F_psdt0(DIST_SHAPE,Nk) , F_tdt0 (DIST_SHAPE,Nk) ,
% F_qpt0 (DIST_SHAPE,Nk) , F_wt0 (DIST_SHAPE,Nk) ,
% F_mut0 (DIST_SHAPE,Nk) , F_multx(DIST_SHAPE,Nk) ,
% F_gptx (DIST_SHAPE,Nk) , F_gxtx (DIST_SHAPE,Nk) ,
% F_ru (DIST_SHAPE,Nk) , F_rv (DIST_SHAPE,Nk) ,
% F_rcn (DIST_SHAPE,Nk) , F_rth (DIST_SHAPE,Nk) ,
% F_rvv (DIST_SHAPE,Nk) , F_nth (DIST_SHAPE,Nk) ,
% F_r3 (DIST_SHAPE,Nk) , F_r3p (DIST_SHAPE,Nk) ,
% F_nu (DIST_SHAPE,Nk) , F_nv (DIST_SHAPE,Nk) ,
% F_n3 (DIST_SHAPE,Nk) , F_n3p (DIST_SHAPE,Nk) ,
% F_ncn (DIST_SHAPE,Nk) ,
% F_wijk0(DIST_SHAPE,Nk) , F_wijk1(DIST_SHAPE,Nk)
*
real F_st0m (DIST_SHAPE) ,
% F_pipt0m(DIST_SHAPE,Nk), F_qt0m (DIST_SHAPE,Nk),
% F_fit0m (DIST_SHAPE,Nk), F_fipt0m(DIST_SHAPE,Nk),
% F_tt0m (DIST_SHAPE,Nk),
% F_tpt0m (DIST_SHAPE,Nk), F_tplt0m(DIST_SHAPE,Nk),
% F_ut0m (DIST_SHAPE,Nk), F_vt0m (DIST_SHAPE,Nk),
% F_psdt0m(DIST_SHAPE,Nk), F_tdt0m (DIST_SHAPE,Nk),
% F_qpt0m (DIST_SHAPE,Nk), F_wt0m (DIST_SHAPE,Nk),
% F_mut0m (DIST_SHAPE,Nk), F_multxm(DIST_SHAPE,Nk),
% F_gptxm (DIST_SHAPE,Nk), F_gxtxm (DIST_SHAPE,Nk),
% F_rum (DIST_SHAPE,Nk), F_rvm (DIST_SHAPE,Nk),
% F_rcnm (DIST_SHAPE,Nk), F_rthm (DIST_SHAPE,Nk),
% F_rvvm (DIST_SHAPE,Nk), F_nthm (DIST_SHAPE,Nk),
% F_r3m (DIST_SHAPE,Nk), F_r3pm (DIST_SHAPE,Nk),
% F_num (DIST_SHAPE,Nk), F_nvm (DIST_SHAPE,Nk),
% F_n3m (DIST_SHAPE,Nk), F_n3pm (DIST_SHAPE,Nk),
% F_ncnm (DIST_SHAPE,Nk),
% F_wijk0m(DIST_SHAPE,Nk), F_wijk1m(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
* - adapt for tracers in tr3d
* v3_00 - Tanguay M. - adapt to restructured bacp_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
* v3_30 - Tanguay M. - Enforce similarities between NL and TRAJ TL
*
*object
* see id section
* ------------------------------------------------------------------------
* REMARK: INPUT TRAJ: F_gptxm, F_rthm, F_nthm,
* F_r3m, F_r3pm, F_rvvm, F_n3m, F_n3pm (NoHyd)
* ------------------------------------------------------------------------
*
*arguments
* see documentation of appropriate comdecks
*
*implicits
#include "glb_ld.cdk"
*
integer i0, j0, in, jn
*
i0 = 1+pil_w
in = l_ni-pil_e
j0 = 1+pil_s
jn = l_nj-pil_n
*
call bacp_2_2_tl
$ ( F_itr ,F_itnlh, F_st0 ,F_pipt0 ,
$ F_qt0 ,F_fit0 , F_fipt0 ,F_fis ,F_tt0 ,
$ F_tpt0 ,F_tplt0, F_ut0 ,F_vt0 ,F_psdt0 ,
$ F_tdt0 ,F_qpt0 , F_wt0 ,
$ F_mut0 ,F_multx, F_gptx ,F_gxtx ,
$ F_ru ,F_rv , F_rth ,F_r3 ,F_r3p ,
$ F_rvv ,F_rcn , F_nu ,F_nv ,
$ F_nth ,F_n3 , F_n3p ,
$ F_ncn ,F_wijk0, F_wijk1 ,
*
$ F_st0m ,F_pipt0m,
$ F_qt0m ,F_fit0m ,F_fipt0m, F_tt0m ,
$ F_tpt0m,F_tplt0m,F_ut0m ,F_vt0m ,F_psdt0m,
$ F_tdt0m,F_qpt0m ,F_wt0m ,
$ F_mut0m,F_multxm,F_gptxm ,F_gxtxm ,
$ F_rum ,F_rvm ,F_rthm ,F_r3m ,F_r3pm ,
$ F_rvvm ,F_rcnm ,F_num ,F_nvm ,
$ F_nthm ,F_n3m ,F_n3pm ,
$ F_ncnm ,F_wijk0m,F_wijk1m,
*
$ DIST_DIM, Nk, i0, j0, in, jn )
*
return
end
*
subroutine bacp_2_2_tl 1
$ ( F_itr ,F_itnlh, F_st0 ,F_pipt0 ,
$ F_qt0 ,F_fit0 , F_fipt0 ,F_fis ,F_tt0 ,
$ F_tpt0 ,F_tplt0, F_ut0 ,F_vt0 ,F_psdt0 ,
$ F_tdt0 ,F_qpt0 , F_wt0 ,
$ F_mut0 ,F_multx, F_gptx ,F_gxtx ,
$ F_ru ,F_rv , F_rth ,F_r3 ,F_r3p ,
$ F_rvv ,F_rcn , F_nu ,F_nv ,
$ F_nth ,F_n3 , F_n3p ,
$ F_ncn ,F_wijk0, F_wijk1 ,
*
$ F_st0m ,F_pipt0m,
$ F_qt0m ,F_fit0m ,F_fipt0m, F_tt0m ,
$ F_tpt0m,F_tplt0m,F_ut0m ,F_vt0m ,F_psdt0m,
$ F_tdt0m,F_qpt0m ,F_wt0m ,
$ F_mut0m,F_multxm,F_gptxm ,F_gxtxm ,
$ F_rum ,F_rvm ,F_rthm ,F_r3m ,F_r3pm ,
$ F_rvvm ,F_rcnm ,F_num ,F_nvm ,
$ F_nthm ,F_n3m ,F_n3pm ,
$ F_ncnm ,F_wijk0m,F_wijk1m,
*
$ DIST_DIM, Nk, i0, j0, in, jn )
*
implicit none
*
integer F_itr, F_itnlh, DIST_DIM, Nk, i0, j0, in, jn
real F_st0 (DIST_SHAPE) ,
% F_pipt0(DIST_SHAPE,Nk) , F_qt0 (DIST_SHAPE,Nk) ,
% F_fit0 (DIST_SHAPE,Nk) , F_fipt0(DIST_SHAPE,Nk) ,
% F_fis (DIST_SHAPE) , F_tt0 (DIST_SHAPE,Nk) ,
% F_tpt0 (DIST_SHAPE,Nk) , F_tplt0(DIST_SHAPE,Nk) ,
% F_ut0 (DIST_SHAPE,Nk) , F_vt0 (DIST_SHAPE,Nk) ,
% F_psdt0(DIST_SHAPE,Nk) , F_tdt0 (DIST_SHAPE,Nk) ,
% F_qpt0 (DIST_SHAPE,Nk) , F_wt0 (DIST_SHAPE,Nk) ,
% F_mut0 (DIST_SHAPE,Nk) , F_multx(DIST_SHAPE,Nk) ,
% F_gptx (DIST_SHAPE,Nk) , F_gxtx (DIST_SHAPE,Nk) ,
% F_ru (DIST_SHAPE,Nk) , F_rv (DIST_SHAPE,Nk) ,
% F_rcn (DIST_SHAPE,Nk) , F_rth (DIST_SHAPE,Nk) ,
% F_rvv (DIST_SHAPE,Nk) , F_nth (DIST_SHAPE,Nk) ,
% F_r3 (DIST_SHAPE,Nk) , F_r3p (DIST_SHAPE,Nk) ,
% F_nu (DIST_SHAPE,Nk) , F_nv (DIST_SHAPE,Nk) ,
% F_n3 (DIST_SHAPE,Nk) , F_n3p (DIST_SHAPE,Nk) ,
% F_ncn (DIST_SHAPE,Nk) ,
% F_wijk0(DIST_SHAPE,Nk) , F_wijk1(DIST_SHAPE,Nk)
*
real F_st0m (DIST_SHAPE) ,
% F_pipt0m(DIST_SHAPE,Nk), F_qt0m (DIST_SHAPE,Nk),
% F_fit0m (DIST_SHAPE,Nk), F_fipt0m(DIST_SHAPE,Nk),
% F_tt0m (DIST_SHAPE,Nk),
% F_tpt0m (DIST_SHAPE,Nk), F_tplt0m(DIST_SHAPE,Nk),
% F_ut0m (DIST_SHAPE,Nk), F_vt0m (DIST_SHAPE,Nk),
% F_psdt0m(DIST_SHAPE,Nk), F_tdt0m (DIST_SHAPE,Nk),
% F_qpt0m (DIST_SHAPE,Nk), F_wt0m (DIST_SHAPE,Nk),
% F_mut0m (DIST_SHAPE,Nk), F_multxm(DIST_SHAPE,Nk),
% F_gptxm (DIST_SHAPE,Nk), F_gxtxm (DIST_SHAPE,Nk),
% F_rum (DIST_SHAPE,Nk), F_rvm (DIST_SHAPE,Nk),
% F_rcnm (DIST_SHAPE,Nk), F_rthm (DIST_SHAPE,Nk),
% F_rvvm (DIST_SHAPE,Nk), F_nthm (DIST_SHAPE,Nk),
% F_r3m (DIST_SHAPE,Nk), F_r3pm (DIST_SHAPE,Nk),
% F_num (DIST_SHAPE,Nk), F_nvm (DIST_SHAPE,Nk),
% F_n3m (DIST_SHAPE,Nk), F_n3pm (DIST_SHAPE,Nk),
% F_ncnm (DIST_SHAPE,Nk),
% F_wijk0m(DIST_SHAPE,Nk), F_wijk1m(DIST_SHAPE,Nk)
*
*implicits
#include "glb_ld.cdk"
#include "cori.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "schm.cdk"
*
integer i, j, k, nij
real*8 ZERO_8, ONE_8, TWO_8, HALF_8, QUARTER_8, gamma_8, eps_8
real*8 aaa_8,bbb_8,ccc_8,ddd_8,a1_8,b1_8,b2_8,xxx_8,xx1_8,
% yyy_8,zzz_8,pd2_8,aaa1_8,aaa2_8,bbb1_8,bbb2_8,bbb3_8,
% ccc1_8,ccc2_8,ddd1_8
real*8 xxx_m_8, xx1_m_8, yyy_m_8, zzz_m_8, pd2_m_8
parameter( ZERO_8=0.0, ONE_8=1.0, TWO_8=2.0, HALF_8=.5, QUARTER_8=.25 )
real*8 tmp_8, c1_8, inv_z_8(G_nk), c2_8, c3_8
real*8, dimension(i0:in,j0:jn):: xexpm_8, yexpm_8, xlogm_8,
% ylogm_8, rpipm_8, xrecm_8, yrecm_8, qpm_8, eqpm_8
real exp_m,rec_m
*
nij = (in - i0 + 1)*(jn - j0 + 1)
*
* Constants for nonhydro distortion
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
*
do k = 1, G_nk
inv_z_8(k) = 1.0d0 / Geomg_z_8(k)
end do
*
**********************************************************
* 1. Retrieve the nonhydro deviation q' of log pressure *
**********************************************************
aaa_8 = gamma_8/( Dcst_cappa_8*Cstv_tau_8*Dcst_rgasd_8*Cstv_tstr_8 )
aaa1_8 = Dcst_rgasd_8*Cstv_tstr_8
aaa2_8 = ONE_8/Dcst_rayt_8**2
bbb_8 = Geomg_z_8(l_nk) / ( Dcst_rgasd_8*Cstv_tstr_8 )
bbb1_8 = Dcst_cappa_8*Cstv_tstr_8
bbb2_8 = ONE_8/(Dcst_grav_8*Cstv_tau_8)
bbb3_8 = Schm_nonhy_8/((Dcst_grav_8**2)*(Cstv_tau_8**2))
c1_8 = 1.0d0 / Dcst_cappa_8
c2_8 = 1.0d0 / Geomg_pib(l_nk)
c3_8 = 1.0d0 / Dcst_grav_8
ccc_8 = Schm_nonhy_8*gamma_8/( Dcst_grav_8**2 * Cstv_tau_8**3 )
ccc1_8 = Geomg_z_8(l_nk) * c2_8
ccc2_8 = Dcst_rgasd_8*Cstv_tstr_8
ddd_8 = Schm_nonhy_8 * gamma_8
% /( Dcst_cappa_8 * Dcst_grav_8**2 * Cstv_tau_8**3 )
ddd1_8 = Cstv_tau_8*Cstv_tstr_8
*
!$omp parallel private (xlogm_8,ylogm_8,xrecm_8,yrecm_8,rpipm_8,
!$omp% qpm_8, eqpm_8, exp_m, rec_m,
!$omp% xxx_m_8,yyy_m_8,zzz_m_8,pd2_m_8,xx1_m_8,
!$omp% xxx_8, yyy_8, zzz_8, pd2_8, xx1_8,
!$omp% b1_8, b2_8, a1_8, tmp_8)
*
if (.not. Schm_hydro_L) then
* TRAJECTORY
* ----------
F_qpt0m(:,:,1) = ZERO_8
*
* TLM
* ---
F_qpt0(:,:,1) = ZERO_8
*
!$omp do
do j= j0, jn
do k=1,l_nk-1
xxx_8 = HALF_8*Geomg_hz_8(k)
yyy_8 = (ccc_8*c1_8)*HALF_8*( Geomg_z_8(k) + Geomg_z_8(k+1) )
zzz_8 = Cstv_tau_8*inv_z_8(k)
do i= i0, in
*
* TRAJECTORY
* ----------
F_qpt0m(i,j,k+1) = F_qpt0m(i,j,k)
% + xxx_8*( gamma_8*(F_n3pm(i,j,k+1)-F_r3pm(i,j,k+1))
% + ccc_8*F_gptxm(i,j,k+1) + gamma_8*(F_n3pm(i,j,k)-F_r3pm(i,j,k))
% + ccc_8*F_gptxm(i,j,k) ) + yyy_8*(F_gptxm(i,j,k+1)-F_gptxm(i,j,k))
F_qpt0m(i,j,k) = zzz_8*F_qpt0m(i,j,k)
*
* TLM
* ---
F_qpt0(i,j,k+1) = F_qpt0(i,j,k)
% + xxx_8*( gamma_8*(F_n3p (i,j,k+1)-F_r3p(i,j,k+1))
% + ccc_8* F_gptx(i,j,k+1)
% + gamma_8*(F_n3p (i,j,k )-F_r3p(i,j,k ))
% + ccc_8* F_gptx(i,j,k)
% )
% + yyy_8*(F_gptx(i,j,k+1)-F_gptx(i,j,k))
F_qpt0(i,j,k) = zzz_8*F_qpt0(i,j,k)
*
end do
end do
end do
!$omp enddo
!$omp do
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_qpt0m(i,j,l_nk) = Cstv_tau_8*F_qpt0m(i,j,l_nk)*inv_z_8(l_nk)
*
* TLM
* ---
F_qpt0(i,j,l_nk) = Cstv_tau_8*F_qpt0(i,j,l_nk)*inv_z_8(l_nk)
*
end do
end do
!$omp enddo
endif
******************************************
* 2. Compute s, pi'lin, pi', q and phi' *
******************************************
* Compute s
* ~~~~~~~~~
!$omp do
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_st0m(i,j) = bbb_8*F_gptxm(i,j,l_nk)*c2_8
*
* TLM
* ---
F_st0(i,j) = bbb_8*F_gptx(i,j,l_nk)*c2_8
*
end do
end do
!$omp enddo
*
if (.not. Schm_hydro_L) then
!$omp do
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_st0m(i,j) = F_st0m(i,j) - ccc1_8*F_qpt0m(i,j,l_nk)
*
* TLM
* ---
F_st0(i,j) = F_st0(i,j) - ccc1_8*F_qpt0(i,j,l_nk)
*
end do
end do
!$omp enddo
endif
*
* Compute pi'lin (F_wijk0), pi', q and phi'
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
!$omp do
do j= j0, jn
do i= i0, in
xexpm_8(i,j) = F_st0m(i,j)
end do
end do
!$omp enddo
*
!$omp single
call vexp ( yexpm_8, xexpm_8, nij )
!$omp end single
*
!$omp do
do 100 k=1,l_nk
if (k.eq.1) then
* Impose the boundary conditions
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_pipt0m(i,j,1) = Geomg_pib(1) *(yexpm_8(i,j)-ONE_8)
xlogm_8 (i,j) = Geomg_z_8(1) + F_pipt0m(i,j,1)
*
* TLM
* ---
F_pipt0(i,j,1) = Geomg_pib(1) *(F_st0(i,j)*yexpm_8(i,j))
*
end do
end do
*
call vlog ( ylogm_8, xlogm_8, nij )
call vrec ( rpipm_8, xlogm_8, nij )
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_qt0m (i,j,1) = ylogm_8(i,j)
F_fipt0m(i,j,1) = F_gptxm (i,j,1)
F_gxtxm (i,j,1) = 0.
*
* TLM
* ---
F_qt0 (i,j,1) = F_pipt0(i,j,1) * rpipm_8(i,j)
F_fipt0(i,j,1) = F_gptx (i,j,1)
F_gxtx (i,j,1) = 0.
*
end do
end do
*
else
yyy_8 = Dcst_rgasd_8*Cstv_tstr_8 * inv_z_8(k)
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_pipt0m(i,j,k)= Geomg_pib(k)*(yexpm_8(i,j)-ONE_8)
xlogm_8 (i,j) = Geomg_z_8(k) + F_pipt0m(i,j,k)
*
* TLM
* ---
F_pipt0(i,j,k)= Geomg_pib(k)*(F_st0(i,j)*yexpm_8(i,j))
*
end do
end do
*
call vlog ( ylogm_8, xlogm_8, nij )
call vrec ( rpipm_8, xlogm_8, nij )
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk0m(i,j,k)= Geomg_pib(k) * F_st0m(i,j)
F_qt0m(i,j,k)= ylogm_8(i,j)
F_fipt0m(i,j,k)= F_gptxm(i,j,k) - yyy_8*F_wijk0m(i,j,k)
*
* TLM
* ---
F_wijk0(i,j,k)= Geomg_pib(k) * F_st0(i,j)
F_qt0(i,j,k)= F_pipt0(i,j,k) * rpipm_8(i,j)
F_fipt0(i,j,k)= F_gptx(i,j,k) - yyy_8*F_wijk0(i,j,k)
*
end do
end do
*
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_qt0m (i,j,k) = F_qt0m(i,j,k) + F_qpt0m(i,j,k)
F_fipt0m(i,j,k) = F_fipt0m(i,j,k) - ccc2_8*F_qpt0m(i,j,k)
*
* TLM
* ---
F_qt0 (i,j,k) = F_qt0(i,j,k) + F_qpt0(i,j,k)
F_fipt0(i,j,k) = F_fipt0(i,j,k) - ccc2_8*F_qpt0(i,j,k)
*
end do
end do
endif
endif
if (k.eq.l_nk) then
*
* TRAJECTORY
* ----------
F_fipt0m(:,:,l_nk) = ZERO_8
*
* TLM
* ---
F_fipt0(:,:,l_nk) = ZERO_8
*
endif
*******************************
* 3. Retrieve the variable X *
*******************************
*
* Compute term {1} (F_wijk1) without vertical staggering
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk1m(i,j,k) = F_nthm(i,j,k) - F_rthm(i,j,k)
*
* TLM
* ---
F_wijk1(i,j,k) = F_nth(i,j,k) - F_rth(i,j,k)
*
end do
end do
*
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk1m(i,j,k) = F_wijk1m(i,j,k) + F_n3m(i,j,k) - F_r3m(i,j,k)
*
* TLM
* ---
F_wijk1(i,j,k) = F_wijk1(i,j,k) + F_n3(i,j,k) - F_r3(i,j,k)
*
end do
end do
endif
*
xxx_8 = gamma_8/Dcst_cappa_8*Geomg_z_8(k)
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk1m(i,j,k) = xxx_8*F_wijk1m(i,j,k)
*
* TLM
* ---
F_wijk1(i,j,k) = xxx_8*F_wijk1(i,j,k)
*
end do
end do
*
* Compute {1} - {2} (F_wijk1)
* ~~~~~~~~~~~~~~~~~~~~~~~~~
*
if (.not. Schm_hydro_L) then
b1_8 = Geomg_z_8(k)/Cstv_tau_8
b2_8 = ddd_8*Geomg_z_8(k)
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk1m(i,j,k)= F_wijk1m(i,j,k)-b1_8*F_qpt0m(i,j,k)
$ +b2_8*F_gptxm(i,j,k)
*
* TLM
* ---
F_wijk1(i,j,k)= F_wijk1(i,j,k)-b1_8*F_qpt0(i,j,k)
$ +b2_8*F_gptx(i,j,k)
*
end do
end do
endif
100 continue
!$omp enddo
*
!$omp do
do j= j0, jn
*
do k=1,l_nk-1
a1_8=aaa_8*QUARTER_8*(Geomg_z_8(k)+Geomg_z_8(k+1))**2/Geomg_hz_8(k)
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk1m(i,j,k) = HALF_8*( F_wijk1m(i,j,k+1) + F_wijk1m(i,j,k) )
% - a1_8*( F_gptxm (i,j,k+1) - F_gptxm (i,j,k) )
*
* TLM
* ---
F_wijk1(i,j,k) = HALF_8*( F_wijk1(i,j,k+1) + F_wijk1(i,j,k) )
% - a1_8*( F_gptx (i,j,k+1) - F_gptx (i,j,k) )
*
end do
end do
* Compute the desired variable X
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do k=1,l_nk-1
do i= i0, in
*
* TRAJECTORY
* ----------
F_gxtxm(i,j,k+1) = - F_gxtxm(i,j,k) + TWO_8*F_wijk1m(i,j,k)
*
* TLM
* ---
F_gxtx(i,j,k+1) = - F_gxtx(i,j,k) + TWO_8*F_wijk1(i,j,k)
*
end do
end do
end do
!$omp enddo
*
**********************************************************
* 4. Calculate vertical velocity & nonhydrostatic index *
**********************************************************
*
!$omp do
do j= j0, jn
do i= i0, in
xexpm_8(i,j) = F_st0m(i,j)
end do
end do
!$omp enddo
*
!$omp single
call vexp ( yexpm_8, xexpm_8, nij )
!$omp end single
*
!$omp do
do 300 k=1,l_nk
*
if (.not. Schm_hydro_L) then
*
a1_8 = aaa1_8*Cstv_tau_8*inv_z_8(k)
do j= j0, jn
do i= i0, in
*
exp_m = exp(F_qpt0m(i,j,k))
*
* TRAJECTORY
* ----------
zzz_m_8 = 1.0 / (1.0 + Geomg_dpib(k)*(yexpm_8(i,j) -1.0))
xxx_m_8 = F_gptxm(i,j,k)-aaa1_8*F_qpt0m(i,j,k)-a1_8*F_gxtxm(i,j,k)
F_wt0m (i,j,k)= - F_rvvm(i,j,k)*c3_8 + bbb2_8*xxx_m_8
F_multxm(i,j,k)= Cstv_tau_8
$ *(F_n3m(i,j,k)-F_r3m(i,j,k))+bbb3_8*xxx_m_8
yyy_m_8 = (1.+F_pipt0m(i,j,k)*inv_z_8(k))*
$ (F_multxm(i,j,k)-F_qpt0m(i,j,k))
F_mut0m(i,j,k) = exp_m-1.
$ +exp_m*zzz_m_8*yyy_m_8
*
* TLM
* ---
zzz_8 = - ( Geomg_dpib(k)*(yexpm_8(i,j)*F_st0(i,j))) /
$ (1.0 + Geomg_dpib(k)*(yexpm_8(i,j) -1.0)) **2
xxx_8 = F_gptx(i,j,k)-aaa1_8*F_qpt0(i,j,k)-a1_8*F_gxtx(i,j,k)
F_wt0 (i,j,k)= - F_rvv(i,j,k)*c3_8 + bbb2_8*xxx_8
F_multx(i,j,k)= Cstv_tau_8
$ *(F_n3(i,j,k)-F_r3(i,j,k))+bbb3_8*xxx_8
yyy_8 = (1.+F_pipt0m(i,j,k)*inv_z_8(k))*
$ (F_multx (i,j,k)-F_qpt0 (i,j,k)) +
$ ( F_pipt0 (i,j,k)*inv_z_8(k))*
$ (F_multxm(i,j,k)-F_qpt0m(i,j,k))
F_mut0(i,j,k) = exp_m*F_qpt0(i,j,k)
$ +exp_m*zzz_m_8*yyy_8
$ +exp_m*zzz_8 *yyy_m_8
$ +exp_m*F_qpt0(i,j,k)*zzz_m_8*yyy_m_8
*
end do
end do
*
endif
*
**********************************************
* 5. Calculate the temperature perturbation *
**********************************************
* Calculate T'lin and prepare {$} (F_wijk1)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a1_8 = Dcst_cappa_8*inv_z_8(k)
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_tplt0m(i,j,k) = ddd1_8*(F_rthm(i,j,k) - F_nthm(i,j,k) +
$ a1_8*F_gxtxm(i,j,k))
*
* TLM
* ---
F_tplt0(i,j,k) = ddd1_8*(F_rth(i,j,k) - F_nth(i,j,k) +
$ a1_8*F_gxtx(i,j,k))
*
end do
end do
*
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_tplt0m(i,j,k) = F_tplt0m(i,j,k) + bbb1_8*F_qpt0m(i,j,k)
*
* TLM
* ---
F_tplt0(i,j,k) = F_tplt0(i,j,k) + bbb1_8*F_qpt0(i,j,k)
*
end do
end do
endif
*
* Calculate T'
* ~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
xrecm_8(i,j) = 1.0 + Geomg_dpib(k) * (yexpm_8(i,j) - 1.0)
end do
end do
call vrec ( yrecm_8, xrecm_8, nij )
*
if (Schm_hydro_L) then
*
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_wijk0m(i,j,k)= yrecm_8(i,j)
F_wijk1m(i,j,k)= F_st0m(i,j) * Geomg_dpib(k)
pd2_m_8 = Geomg_pib(k) * F_st0m(i,j) * inv_z_8(k)
xxx_m_8 = (1. + F_pipt0m(i,j,k)*inv_z_8(k)) * F_wijk0m(i,j,k)
yyy_m_8 = F_tplt0m(i,j,k) - Cstv_tstr_8 * (( pd2_m_8 -
% F_wijk1m(i,j,k)) -1. )
F_tpt0m(i,j,k) = xxx_m_8*yyy_m_8 - Cstv_tstr_8
*
* TLM
* ---
F_wijk0(i,j,k)=-(Geomg_dpib(k) *(F_st0(i,j)*yexpm_8(i,j)))*yrecm_8(i,j)*yrecm_8(i,j)
F_wijk1(i,j,k)= F_st0(i,j) * Geomg_dpib(k)
pd2_8 = Geomg_pib(k) * F_st0(i,j) * inv_z_8(k)
xxx_8 = ( F_pipt0 (i,j,k)*inv_z_8(k)) * F_wijk0m(i,j,k) +
% (1. + F_pipt0m(i,j,k)*inv_z_8(k)) * F_wijk0 (i,j,k)
yyy_8 = F_tplt0(i,j,k) - Cstv_tstr_8 * (( pd2_8 -
% F_wijk1(i,j,k)) )
F_tpt0(i,j,k) = xxx_8*yyy_m_8 + xxx_m_8*yyy_8
*
end do
end do
*
else
*
do j= j0, jn
do i= i0, in
*
exp_m = exp(F_qpt0m(i,j,k))
*
rec_m = 1.0 / ( 1.0 + Geomg_dpib(k) * (exp(F_st0m(i,j))-1.) )
*
* TRAJECTORY
* ----------
F_wijk0m(i,j,k)= rec_m
F_wijk1m(i,j,k)= F_st0m(i,j) * Geomg_dpib(k)
pd2_m_8 = Geomg_pib(k) * F_st0m(i,j) * inv_z_8(k)
xx1_m_8 = (1. + F_pipt0m(i,j,k)*inv_z_8(k)) * F_wijk0m(i,j,k)
xxx_m_8 = xx1_m_8 * exp_m
yyy_m_8 = F_tplt0m(i,j,k)-Cstv_tstr_8*((pd2_m_8-F_wijk1m(i,j,k)+
$ F_qpt0m(i,j,k))-1.)
F_tpt0m(i,j,k) = xxx_m_8*yyy_m_8 - Cstv_tstr_8
*
* TLM
* ---
F_wijk0(i,j,k)=
$ - ( Geomg_dpib(k) * (exp(F_st0m(i,j))*F_st0(i,j)))*rec_m*rec_m
F_wijk1(i,j,k)= F_st0(i,j) * Geomg_dpib(k)
pd2_8 = Geomg_pib(k) * F_st0(i,j) * inv_z_8(k)
xx1_8 = (1. + F_pipt0m(i,j,k)*inv_z_8(k)) * F_wijk0 (i,j,k) +
$ ( F_pipt0 (i,j,k)*inv_z_8(k)) * F_wijk0m(i,j,k)
xxx_8 = xx1_m_8 * exp_m *F_qpt0(i,j,k) + xx1_8 * exp_m
yyy_8 = F_tplt0(i,j,k)-Cstv_tstr_8*(pd2_8-F_wijk1(i,j,k)+
$ F_qpt0(i,j,k))
F_tpt0(i,j,k) = xxx_m_8*yyy_8 + xxx_8*yyy_m_8
*
enddo
enddo
endif
*
300 continue
!$omp enddo
*
if (Cori_cornl_L) then
*
!$omp single
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_gptxm, 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_gptx, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
*
!$omp end single
*
!$omp do
do 600 k=1,l_nk
* Compute gradient of P and hence U & V
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, l_niu-pil_e
*
* TRAJECTORY
* ----------
F_ut0m(i,j,k)= Cstv_tau_8*( F_rum(i,j,k)-F_num(i,j,k) - aaa2_8*
$ (F_gptxm(i+1,j,k)-F_gptxm(i,j,k)) / Geomg_hx_8(i) )
* TLM
* ---
F_ut0(i,j,k) = Cstv_tau_8*( F_ru(i,j,k) -F_nu(i,j,k) - aaa2_8*
$ (F_gptx(i+1,j,k) -F_gptx(i,j,k) ) / Geomg_hx_8(i) )
*
end do
end do
do j= j0, l_njv-pil_n
do i= i0, in
*
* TRAJECTORY
* ----------
F_vt0m(i,j,k)= Cstv_tau_8*( F_rvm(i,j,k)-F_nvm(i,j,k) - aaa2_8*
$ (F_gptxm(i,j+1,k) - F_gptxm(i,j,k))
$ *Geomg_cyv2_8(j)*Geomg_invhsy_8(j) )
* TLM
* ---
F_vt0(i,j,k) = Cstv_tau_8*( F_rv(i,j,k) -F_nv(i,j,k) - aaa2_8*
$ (F_gptx(i,j+1,k) - F_gptx(i,j,k) )
$ *Geomg_cyv2_8(j)*Geomg_invhsy_8(j) )
*
end do
end do
600 continue
!$omp enddo
endif
*************************************************************
* $. Final back substitution after the nonlinear iteration *
*************************************************************
*
if ( .not. (F_itr .lt. F_itnlh) ) then
*
!$omp single
if (.not.Cori_cornl_L) then
*
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo( F_gptxm, 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_gptx, 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 700 k=1,l_nk
if (.not.Cori_cornl_L) then
* Compute gradient of P and hence U & V
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, l_niu-pil_e
*
* TRAJECTORY
* ----------
F_ut0m(i,j,k)= Cstv_tau_8*( F_rum(i,j,k)-F_num(i,j,k) - aaa2_8*
$ (F_gptxm(i+1,j,k)-F_gptxm(i,j,k)) / Geomg_hx_8(i) )
*
* TLM
* ---
F_ut0(i,j,k) = Cstv_tau_8*( F_ru(i,j,k) -F_nu(i,j,k) - aaa2_8*
$ (F_gptx(i+1,j,k) -F_gptx(i,j,k) ) / Geomg_hx_8(i) )
*
end do
end do
*
do j= j0, l_njv-pil_n
do i= i0, in
*
* TRAJECTORY
* ----------
F_vt0m(i,j,k)= Cstv_tau_8*( F_rvm(i,j,k)-F_nvm(i,j,k) - aaa2_8*
$ (F_gptxm(i,j+1,k) - F_gptxm(i,j,k))
$ *Geomg_cyv2_8(j)*Geomg_invhsy_8(j) )
*
* TLM
* ---
F_vt0(i,j,k) = Cstv_tau_8*( F_rv(i,j,k) -F_nv(i,j,k) - aaa2_8*
$ (F_gptx(i,j+1,k) - F_gptx(i,j,k) )
$ *Geomg_cyv2_8(j)*Geomg_invhsy_8(j) )
*
end do
end do
endif
* Compute pi*-dot
* ~~~~~~~~~~~~~~~
if ( (k.eq.1) .or. (k.eq.l_nk) ) then
F_psdt0m(:,:,k) = ZERO_8
F_psdt0 (:,:,k) = ZERO_8
else
tmp_8 = Geomg_pib(k)/Cstv_tau_8
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_psdt0m(i,j,k) = F_gxtxm(i,j,k) - tmp_8*F_st0m(i,j)
*
* TLM
* ---
F_psdt0(i,j,k) = F_gxtx(i,j,k) - tmp_8*F_st0(i,j)
*
end do
end do
endif
* Compute total divergence
* ~~~~~~~~~~~~~~~~~~~~~~~~
tmp_8 = Geomg_dpib(k)/Cstv_tau_8
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_tdt0m(i,j,k) = F_rcnm(i,j,k) - F_ncnm(i,j,k) - tmp_8*F_st0m(i,j)
*
* TLM
* ---
F_tdt0(i,j,k) = F_rcn(i,j,k) - F_ncn(i,j,k) - tmp_8*F_st0(i,j)
*
end do
end do
* Compute phi and T
* ~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
*
* TRAJECTORY
* ----------
F_fit0m(i,j,k) = F_fipt0m(i,j,k) + Cstvr_fistr_8(k) + F_fis(i,j)
F_tt0m(i,j,k) = F_tpt0m(i,j,k) + Cstv_tstr_8
*
* TLM
* ---
F_fit0(i,j,k) = F_fipt0(i,j,k)
F_tt0(i,j,k) = F_tpt0(i,j,k)
*
end do
end do
*
700 continue
!$omp enddo
endif
!$omp end parallel
* __________________________________________________________________
*
return
end