!-------------------------------------- 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 - backsubstitution ( computation and microtasking )
*
#include "model_macros_f.h"
*
subroutine bacp_2 ( F_itr , F_itnlh, F_st0 , F_pipt0, 2
$ 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, 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)
*
*author
* Alain Patoine - split from bac.ftn
*
*revision
* v2_00 - Desgagne M. - initial MPI version (from rhs v1_03)
* v2_21 - Lee V. - modifications for LAM version
* v2_30 - Edouard S. - adapt for vertical hybrid coordinate
* v2_31 - Desgagne M. - removed treatment of Hu and Qc
* v3_00 - Desgagne & Lee - Lam configuration
* v3_02 - Edouard S. - correct non-hydrostatic version (F_mut0,F_tpt0,bbb3)
* v3_10 - Corbeil & Desgagne & Lee - AIXport+Opti+OpenMP
* v3_21 - Desgagne M. - Revision Openmp
* v3_30 - Desgagne M. - Revision Openmp II
*
*object
* see documentation in s/r bac.
*
*arguments: see documentation of appropriate comdecks
*
*implicits
#include "glb_ld.cdk"
#include "orh.cdk"
#include "cori.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "schm.cdk"
*
integer i, j, k, i0, j0, in, jn, nij
real*8 gamma, eps, aaa, bbb, ccc, ddd, a1, b1, b2, xxx, yyy ,
$ zzz, pd2, aaa1, aaa2, bbb1, bbb2, bbb3, ccc1, ccc2, ddd1,
$ tmp_8, c1_8, c2_8, c3_8, xlog_8(l_ni,l_nj),
$ ylog_8(l_ni,l_nj), yexp_8(l_ni,l_nj),
$ xrec_8(l_ni,l_nj), yrec_8(l_ni,l_nj)
real*8 zero, one, two, half, quarter
parameter( zero=0.0, one=1.0, two=2.0, half=.5, quarter=.25 )
**
* __________________________________________________________________
*
!$omp parallel private( i, j, k, i0, j0, in, jn, nij,
!$omp% gamma, eps, aaa, bbb, ccc, ddd, a1, b1, b2, xxx,
!$omp% yyy, zzz, pd2, aaa1, aaa2, bbb1, bbb2, bbb3,
!$omp% ccc1, ccc2, ddd1, tmp_8, c1_8, c2_8, c3_8,
!$omp% xlog_8, ylog_8, xrec_8, yrec_8 )
!$omp% shared ( yexp_8 )
*
i0 = 1+pil_w
in = l_ni-pil_e
j0 = 1+pil_s
jn = l_nj-pil_n
*
* Constants for nonhydro distortion
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
gamma = one
if (.not. Schm_hydro_L) then
eps = Schm_nonhy_8 * Dcst_rgasd_8 * Cstv_tstr_8
% /( Dcst_cappa_8 * Dcst_grav_8**2 * Cstv_tau_8**2 )
gamma = one/( one + eps )
endif
*
nij = l_ni * l_nj
*
if ( (Cori_cornl_L) .or. (F_itr .lt. F_itnlh) ) then
!$omp single
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
endif
*
**********************************************************
* 1. Retrieve the nonhydro deviation q' of log pressure *
**********************************************************
*
aaa = gamma/( Dcst_cappa_8*Cstv_tau_8*Dcst_rgasd_8*Cstv_tstr_8 )
aaa1 = Dcst_rgasd_8*Cstv_tstr_8
aaa2 = one/Dcst_rayt_8**2
bbb = Geomg_z_8(l_nk) / ( Dcst_rgasd_8*Cstv_tstr_8 )
bbb1 = Dcst_cappa_8*Cstv_tstr_8
bbb2 = one/(Dcst_grav_8*Cstv_tau_8)
bbb3 = 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 = Schm_nonhy_8*gamma/( Dcst_grav_8**2 * Cstv_tau_8**3 )
ccc1 = Geomg_z_8(l_nk) * c2_8
ccc2 = Dcst_rgasd_8*Cstv_tstr_8
ddd = Schm_nonhy_8 * gamma
% /( Dcst_cappa_8 * Dcst_grav_8**2 * Cstv_tau_8**3 )
ddd1 = Cstv_tau_8*Cstv_tstr_8
*
if (.not. Schm_hydro_L) then
*
!$omp do
do j= j0, jn
F_qpt0(:,j,1) = zero
do k=1,l_nk-1
xxx = half*Geomg_hz_8(k)
yyy = (ccc*c1_8)*half*( Geomg_z_8(k) + Geomg_z_8(k+1) )
zzz = Cstv_tau_8*geomg_invz_8(k)
do i= i0, in
F_qpt0(i,j,k+1) = F_qpt0(i,j,k)
% + xxx*( gamma*(F_n3p(i,j,k+1)-F_r3p(i,j,k+1))
% + ccc*F_gptx(i,j,k+1) + gamma*(F_n3p(i,j,k)-F_r3p(i,j,k))
% + ccc*F_gptx(i,j,k) ) + yyy*(F_gptx(i,j,k+1)-F_gptx(i,j,k))
F_qpt0(i,j,k) = zzz*F_qpt0(i,j,k)
end do
end do
do i= i0, in
F_qpt0(i,j,l_nk) =
$ Cstv_tau_8*F_qpt0(i,j,l_nk)*geomg_invz_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
F_st0(i,j) = bbb*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
F_st0(i,j) = F_st0(i,j) - ccc1*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
yexp_8(:,j) = 1.
do i= i0, in
yexp_8(i,j) = F_st0(i,j)
end do
call vexp ( yexp_8(1,j), yexp_8(1,j), l_ni )
end do
!$omp enddo
*
xlog_8 = 1.
xrec_8 = 1.
!$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
F_pipt0(i,j,1) = geomg_pib(1) * (yexp_8(i,j) - one)
xlog_8(i,j) = Geomg_z_8(1) + F_pipt0(i,j,1)
end do
end do
call vlog ( ylog_8, xlog_8, nij )
*
do j= j0, jn
do i= i0, in
F_qt0 (i,j,1) = ylog_8(i,j)
F_fipt0(i,j,1) = F_gptx (i,j,1)
F_gxtx (i,j,1) = 0.
end do
end do
else
xxx = Geomg_z_8(k) - Geomg_z_8(1)
yyy = Dcst_rgasd_8*Cstv_tstr_8 * geomg_invz_8(k)
do j= j0, jn
do i= i0, in
F_pipt0(i,j,k)= geomg_pib(k) * (yexp_8(i,j) - one)
xlog_8(i,j) = Geomg_z_8(k) + F_pipt0(i,j,k)
end do
end do
call vlog ( ylog_8, xlog_8, nij )
do j= j0, jn
do i= i0, in
F_wijk0(i,j,k)= geomg_pib(k) * F_st0(i,j)
F_qt0 (i,j,k)= ylog_8(i,j)
F_fipt0(i,j,k)= F_gptx(i,j,k) - yyy*F_wijk0(i,j,k)
end do
end do
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
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*F_qpt0(i,j,k)
end do
end do
endif
endif
if (k.eq.l_nk) then
F_fipt0 (:,:,l_nk) = zero
endif
*
*******************************
* 3. Retrieve the variable X *
*******************************
*
* Compute term {1} (F_wijk1) without vertical staggering
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
xxx = gamma/Dcst_cappa_8*Geomg_z_8(k)
b1 = Geomg_z_8(k)/Cstv_tau_8
b2 = ddd*Geomg_z_8(k)
do j= j0, jn
do i= i0, in
F_wijk1(i,j,k) = xxx*(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
F_wijk1(i,j,k) = F_wijk1(i,j,k) +
$ xxx*( F_n3(i,j,k) - F_r3(i,j,k) )
$ -b1*F_qpt0(i,j,k) + b2*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=aaa*quarter*(Geomg_z_8(k)+Geomg_z_8(k+1))**2/Geomg_hz_8(k)
do i= i0, in
F_wijk1(i,j,k) = half*( F_wijk1(i,j,k+1) + F_wijk1(i,j,k) )
% - a1*( 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
F_gxtx(i,j,k+1) = - F_gxtx(i,j,k) + two*F_wijk1(i,j,k)
end do
end do
end do
!$omp enddo
*
********************************************************
* 4. Compute vertical velocity & nonhydrostatic index *
********************************************************
*
!$omp do
do 300 k=1,l_nk
*
if (.not. Schm_hydro_L) then
a1 = aaa1*Cstv_tau_8*geomg_invz_8(k)
do j= j0, jn
do i= i0, in
zzz = 1.0 / (1.0 + geomg_dpib(k)*(yexp_8(i,j) - 1.0))
xxx = F_gptx(i,j,k)-aaa1*F_qpt0(i,j,k)-a1*F_gxtx(i,j,k)
F_wt0 (i,j,k)= - F_rvv(i,j,k)*c3_8 + bbb2*xxx
F_multx(i,j,k)= Cstv_tau_8
$ *(F_n3(i,j,k)-F_r3(i,j,k))+bbb3*xxx
yyy = (1.+F_pipt0(i,j,k)*geomg_invz_8(k))*
$ (F_multx(i,j,k)-F_qpt0(i,j,k))
F_mut0(i,j,k) = exp(F_qpt0(i,j,k))-1.
$ +exp(F_qpt0(i,j,k))*zzz*yyy
end do
end do
endif
********************************************
* 5. Compute the temperature perturbation *
********************************************
* Compute T'lin and prepare {$} (F_wijk1)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a1 = Dcst_cappa_8*geomg_invz_8(k)
do j= j0, jn
do i= i0, in
F_tplt0(i,j,k)= ddd1*(F_rth(i,j,k) - F_nth(i,j,k) +
$ a1*F_gxtx(i,j,k))
end do
end do
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
F_tplt0(i,j,k) = F_tplt0(i,j,k) + bbb1*F_qpt0(i,j,k)
end do
end do
endif
*
* Compute T'
* ~~~~~~~~~
do j= j0, jn
do i= i0, in
xrec_8(i,j) = 1.0 + geomg_dpib(k) * (yexp_8(i,j) - 1.0)
end do
end do
call vrec ( yrec_8, xrec_8, nij )
*
if (Schm_hydro_L) then
do j= j0, jn
do i= i0, in
xrec_8(i,j) = (1.+F_pipt0(i,j,k)*geomg_invz_8(k)) * yrec_8(i,j)
yrec_8(i,j) = F_tplt0(i,j,k)-Cstv_tstr_8* ( F_st0(i,j)*(geomg_pib(k) * geomg_invz_8(k) - geomg_dpib(k)) -1. )
end do
end do
else
do j= j0, jn
do i= i0, in
xrec_8(i,j) = (1.+F_pipt0(i,j,k)*geomg_invz_8(k)) * yrec_8(i,j) * exp(F_qpt0(i,j,k))
yrec_8(i,j) = F_tplt0(i,j,k)-Cstv_tstr_8* ( F_st0(i,j)*(geomg_pib(k) * geomg_invz_8(k) - geomg_dpib(k)) + F_qpt0(i,j,k) -1. )
end do
end do
endif
*
do j= j0, jn
do i= i0, in
F_tpt0(i,j,k) = xrec_8(i,j)*yrec_8(i,j) - Cstv_tstr_8
end do
end do
*
300 continue
!$omp enddo
*
if (Cori_cornl_L) then
*
!$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
F_ut0(i,j,k)= Cstv_tau_8*( F_ru(i,j,k)-F_nu(i,j,k) - aaa2*
$ (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
F_vt0(i,j,k)= Cstv_tau_8*( F_rv(i,j,k)-F_nv(i,j,k) - aaa2*
$ (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 do
do 700 k=1,l_nk
if (.not.Cori_cornl_L) then
do j= j0, jn
do i= i0, l_niu-pil_e
F_ut0(i,j,k)= Cstv_tau_8*( F_ru(i,j,k)-F_nu(i,j,k) - aaa2*
$ (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
F_vt0(i,j,k)= Cstv_tau_8*( F_rv(i,j,k)-F_nv(i,j,k) - aaa2*
$ (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
do j= j0, jn
do i= i0, in
F_psdt0(i,j,k) = 0.
end do
end do
else
tmp_8 = geomg_pib(k)/Cstv_tau_8
do j= j0, jn
do i= i0, in
F_psdt0(i,j,k) = F_gxtx(i,j,k) - tmp_8*F_st0(i,j)
end do
end do
endif
*
* Compute total divergence, phi and T
* ~~~~~~~~~~~~~~~~~~~~~~~~
tmp_8 = geomg_dpib(k)/Cstv_tau_8
do j= j0, jn
do i= i0, in
F_tdt0(i,j,k) = F_rcn (i,j,k) - F_ncn(i,j,k) - tmp_8*F_st0(i,j)
F_fit0(i,j,k) = F_fipt0(i,j,k) + Cstvr_fistr_8(k) + F_fis(i,j)
F_tt0 (i,j,k) = F_tpt0 (i,j,k) + Cstv_tstr_8
end do
end do
*
700 continue
!$omp enddo
endif
!$omp end parallel
*
* __________________________________________________________________
*
return
end