!-------------------------------------- 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_ad - ADJ of rhsp_2_tl
*
#include "model_macros_f.h"
*
subroutine rhsp_2_ad ( F_ru, F_rv, F_rcn, F_rth, F_rw, F_rvv, 1,7
% 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_tm, F_qm,
% F_fim, F_sm,
% 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_tm (DIST_SHAPE,Nk), F_qm (DIST_SHAPE,Nk),
% F_fim (DIST_SHAPE,Nk), F_sm (DIST_SHAPE),
% 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. - Validation for LAM Nonhyd
* v3_31 - Tanguay M. - new scope for operator + adw_cliptraj (LAM)
*
*object
* see id section
* -----------------------------------------
* REMARK:INPUT TRAJ:F_tm, F_qm, F_sm, F_fim
* -----------------------------------------
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_ru IO
*----------------------------------------------------------------
*
*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)
*
real*8 xmassm_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 invksm_8(l_ni,l_nj,l_nk)
*
real*8 inv_Cstv_tstr_8
real*8 inv_Geomg_hx_8(l_niu)
real*8 inv_Geomg_z_8(l_nk)
* ______________________________________________________
*
* ---------------------------
* START TRAJECTORY EVALUATION
* ---------------------------
*
* 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_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 )
*
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
*
* -------------------------
* START ADJOINT CALCULATION
* -------------------------
*
!$omp parallel private(i,j,i0,j0,jn,in,i00,inn,j00,jnn,
!$omp$ pd1_8,xmassm_8,invsm_8,invtm_8,
!$omp$ wk1m,wk1,wk2)
*
* ADJOINT of
* Change Ru, Rv values on the boundaries of the LAM grid
*
if (G_lam) then
if (l_north) then
!$omp do
do k=1,l_nk
do i= l_ni-pil_e,1+pil_w,-1
*
F_rv (i,l_nj-pil_n,k) = F_orv(i,l_nj-pil_n,k) + F_rv(i,l_nj-pil_n,k)
F_orv (i,l_nj-pil_n,k) = ZERO_8
*
F_nest_v(i,l_nj-pil_n,k) = - aaa_8* F_rv (i,l_nj-pil_n,k) + F_nest_v(i,l_nj-pil_n,k)
F_rv (i,l_nj-pil_n,k) = ZERO_8
*
enddo
enddo
!$omp enddo
endif
if (l_south) then
!$omp do
do k=1,l_nk
do i= l_ni-pil_e,1+pil_w,-1
*
F_rv (i,pil_s,k) = F_orv(i,pil_s,k) + F_rv(i,pil_s,k)
F_orv (i,pil_s,k) = ZERO_8
*
F_nest_v(i,pil_s,k) = - aaa_8*F_rv(i,pil_s,k) + F_nest_v(i,pil_s,k)
F_rv (i,pil_s,k) = ZERO_8
*
enddo
enddo
!$omp enddo
endif
if (l_east) then
!$omp do
do k=1,l_nk
do j= l_nj-pil_n,1+pil_s,-1
*
F_ru (l_ni-pil_e,j,k) = F_oru(l_ni-pil_e,j,k) + F_ru(l_ni-pil_e,j,k)
F_oru (l_ni-pil_e,j,k) = ZERO_8
*
F_nest_u(l_ni-pil_e,j,k) = - aaa_8*F_ru(l_ni-pil_e,j,k) + F_nest_u(l_ni-pil_e,j,k)
F_ru (l_ni-pil_e,j,k) = ZERO_8
*
enddo
enddo
!$omp enddo
endif
if (l_west) then
!$omp do
do k=1,l_nk
do j= l_nj-pil_n,1+pil_s,-1
*
F_ru (pil_w,j,k) = F_oru(pil_w,j,k) + F_ru(pil_w,j,k)
F_oru (pil_w,j,k) = ZERO_8
*
F_nest_u(pil_w,j,k) = - aaa_8* F_ru(pil_w,j,k) + F_nest_u(pil_w,j,k)
F_ru (pil_w,j,k) = ZERO_8
*
enddo
enddo
!$omp enddo
endif
endif
*
*******************************************************
* ADJ of *
* Interpolate Ru, Rv from U-, V-grid to G-grid, resp. *
*******************************************************
*
* 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
if (.not.G_lam) then
if (l_north) then
do i = i0, in
*
* ADJ
* ---
F_rv(i,jn+1,k) = inuvl_wyvy3_8(jn+1,3) * F_rvw1(i,jn+1,k)
% + F_rv(i,jn+1,k)
F_rv(i,jn ,k) = inuvl_wyvy3_8(jn+1,2) * F_rvw1(i,jn+1,k)
% + F_rv(i,jn ,k)
F_rv(i,jn-1,k) = inuvl_wyvy3_8(jn+1,1) * F_rvw1(i,jn+1,k)
% + F_rv(i,jn-1,k)
F_rvw1(i,jn+1,k) = ZERO_8
*
F_rv(i,jn+1,k) = inuvl_wyvy3_8(jn+2,2) * F_rvw1(i,jn+2,k)
% + F_rv(i,jn+1,k)
F_rv(i,jn ,k) = inuvl_wyvy3_8(jn+2,1) * F_rvw1(i,jn+2,k)
% + F_rv(i,jn ,k)
F_rvw1(i,jn+2,k) = ZERO_8
*
end do
endif
*
if (l_south) then
do i = i0, in
*
* ADJ
* ---
F_rv(i,j0, k) = inuvl_wyvy3_8(j0-1,4) * F_rvw1(i,j0-1,k)
% + F_rv(i,j0,k )
F_rv(i,j0-1,k) = inuvl_wyvy3_8(j0-1,3) * F_rvw1(i,j0-1,k)
% + F_rv(i,j0-1,k)
F_rv(i,j0-2,k) = inuvl_wyvy3_8(j0-1,2) * F_rvw1(i,j0-1,k)
% + F_rv(i,j0-2,k)
F_rvw1(i,j0-1,k) = ZERO_8
*
F_rv(i,j0-1,k) = inuvl_wyvy3_8(j0-2,4) * F_rvw1(i,j0-2,k)
% + F_rv(i,j0-1,k)
F_rv(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * F_rvw1(i,j0-2,k)
% + F_rv(i,j0-2,k)
F_rvw1(i,j0-2,k) = ZERO_8
*
end do
endif
*
endif
*
do j = jn, j0, -1
do i = i0, in
*
* ADJ
* ---
F_rv(i,j+1,k) = inuvl_wyvy3_8(j,4) * F_rvw1(i,j,k) + F_rv(i,j+1,k)
F_rv(i,j ,k) = inuvl_wyvy3_8(j,3) * F_rvw1(i,j,k) + F_rv(i,j ,k)
F_rv(i,j-1,k) = inuvl_wyvy3_8(j,2) * F_rvw1(i,j,k) + F_rv(i,j-1,k)
F_rv(i,j-2,k) = inuvl_wyvy3_8(j,1) * F_rvw1(i,j,k) + F_rv(i,j-2,k)
F_rvw1(i,j, k) = ZERO_8
*
end do
end do
*
end do
!$omp enddo
*
* 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 = in, i0, -1
*
* ADJ
* ---
F_ru(i+1,j,k) = inuvl_wxux3_8(i,4) * F_ruw1(i,j,k) + F_ru(i+1,j,k)
F_ru(i ,j,k) = inuvl_wxux3_8(i,3) * F_ruw1(i,j,k) + F_ru(i ,j,k)
F_ru(i-1,j,k) = inuvl_wxux3_8(i,2) * F_ruw1(i,j,k) + F_ru(i-1,j,k)
F_ru(i-2,j,k) = inuvl_wxux3_8(i,1) * F_ruw1(i,j,k) + F_ru(i-2,j,k)
F_ruw1(i, j,k) = ZERO_8
end do
end do
end do
!$omp enddo
*
!$omp single
*
call rpn_comm_adj_halo ( F_rv,LDIST_DIM,l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
call rpn_comm_adj_halo ( F_ru,LDIST_DIM,l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* Zero F_rv halo
* --------------
call v4d_zerohalo ( F_rv,l_ni,l_njv,LDIST_DIM, l_nk)
*
* Zero F_ru halo
* --------------
call v4d_zerohalo ( F_ru,l_niu,l_nj,LDIST_DIM, l_nk)
*
!$omp end single
*
!$omp do
do 1001 k = l_nk,1,-1
*
* ADJ of
* RHS of vertical momentum, vertical velocity equation *
if (.not. Schm_hydro_L) then
do j= j0, jn
do i= i0, in
*
* ADJ
* ---
F_rvv (i,j,k)= F_orvv(i,j,k) + F_rvv(i,j,k)
F_orvv(i,j,k)= ZERO_8
*
F_rw (i,j,k)= F_orw (i,j,k) + F_rw (i,j,k)
F_orw (i,j,k)= ZERO_8
*
F_fip (i,j,k)= - aaa_8*F_rvv(i,j,k) + F_fip(i,j,k)
F_psd (i,j,k)= c7_8*F_rvv(i,j,k)*inv_Geomg_z_8(k) + F_psd(i,j,k)
F_w (i,j,k)= c6_8*F_rvv(i,j,k) + F_w (i,j,k)
F_rvv (i,j,k)= ZERO_8
*
F_w (i,j,k)= - c5_8*F_rw(i,j,k) + F_w (i,j,k)
F_mu (i,j,k)= c6_8*F_rw(i,j,k) + F_mu(i,j,k)
F_rw (i,j,k)= ZERO_8
*
end do
end do
endif
*
* ADJ of
* 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 vrec( invksm_8(1,1,k), 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 vrec( invtm_8, xmassm_8, nij)
*
pd1_8 = log(Geomg_z_8(k))
do j= j0, jn
do i= i0, in
*
* ADJ
* ---
F_rth (i,j,k) = F_orth(i,j,k) + F_rth(i,j,k)
F_orth(i,j,k) = ZERO_8
*
F_rcn (i,j,k) = F_orcn(i,j,k) + F_rcn(i,j,k)
F_orcn(i,j,k) = ZERO_8
*
F_q (i,j,k) = - c3_8*(-F_rth(i,j,k)) + F_q (i,j,k)
F_psd (i,j,k) = c4_8* F_rth(i,j,k)*inv_Geomg_z_8(k) + F_psd(i,j,k)
F_t (i,j,k) =- aaa_8*( F_rth(i,j,k)*inv_Cstv_tstr_8 )* invtm_8(i,j)
% + F_t (i,j,k)
F_rth (i,j,k) = ZERO_8
*
C F_s (i,j) = -aaa_8*(Geomg_dpba(k)*(F_rcn(i,j,k)*expfm_8(i,j))) * invsm_8(i,j)
C % + F_s(i,j)
C F_td (i,j,k) = -bbb_8* F_rcn(i,j,k) + F_td(i,j,k)
C F_rcn (i,j,k) = ZERO_8
*
end do
end do
*
1001 continue
!$omp enddo
*
!$omp do
do j= j0, jn
*
do k = l_nk,1,-1
do i= i0, in
*
* ADJ
* ---
F_s (i,j) = -aaa_8*(Geomg_dpba(k)*(F_rcn(i,j,k)*expfm_8(i,j))) * invksm_8(i,j,k)
% + F_s(i,j)
F_td (i,j,k) = -bbb_8* F_rcn(i,j,k) + F_td(i,j,k)
F_rcn (i,j,k) = ZERO_8
*
end do
end do
*
end do
!$omp enddo
*
!$omp do
do 1002 k = l_nk,1,-1
*
* Zero adjoint variables
* ----------------------
do j = l_miny,l_maxy
do i = l_minx,l_maxx
wk1(i,j) = ZERO_8
wk2(i,j) = ZERO_8
enddo
enddo
*
* TRAJECTORY
* ----------
if (Schm_hydro_L) then
do j = 1, l_nj
do i = 1, l_ni
*
wk1m(i,j) = ONE_8
*
end do
end do
endif
*
* ADJ
*****************************
* 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))
*
end do
end do
endif
*
if ( abs(c8_8) .lt. 1.0e-6 ) then
do j= jn,j0,-1
do i= in,i0,-1
*
* ADJ
* ---
F_rv (i,j,k) = F_orv(i,j,k) + F_rv(i,j,k)
F_orv(i,j,k) = ZERO_8
*
F_fi(i,j+1,k)= - c2_8 * wk1m(i,j)*( F_rv(i,j,k)) *
% Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
% + F_fi(i,j+1,k)
F_fi(i,j,k) = - c2_8 * wk1m(i,j)*( - F_rv(i,j,k)) *
% Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
% + F_fi(i,j,k)
*
wk1(i,j) = - c2_8 * F_rv(i,j,k) *( F_fim(i,j+1,k) - F_fim(i,j,k) )
% * Geomg_cyv2_8(j) * Geomg_invhsy_8(j) + wk1(i,j)
*
F_t(i,j,k) = - c1_8 * ( ( 1. - intuv_c0yyv_8(j) )*F_rv(i,j,k) )
% * ( F_qm(i,j+1,k) - F_qm(i,j,k) ) *
% Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
% + F_t(i,j,k)
*
F_t(i,j+1,k) = - c1_8 * ( intuv_c0yyv_8(j) *F_rv(i,j,k) )
% * ( F_qm(i,j+1,k) - F_qm(i,j,k) ) *
% Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
% + F_t(i,j+1,k)
*
F_q(i,j+1,k) = - c1_8 * ( ( 1. - intuv_c0yyv_8(j) )*F_tm(i,j,k)
% + intuv_c0yyv_8(j) *F_tm(i,j+1,k) )
% * ( F_rv(i,j,k) ) *
% Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
% + F_q(i,j+1,k)
*
F_q(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_rv(i,j,k) ) *
% Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
% + F_q(i,j,k)
*
F_v(i,j,k) = - aaa_8 * F_rv(i,j,k) + F_v(i,j,k)
F_rv(i,j,k) = ZERO_8
*
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
*
* 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
*
if (.not.G_lam) then
*
if (l_north) then
do i = in,i0,-1
*
* ADJ
* ---
F_rv (i,l_njv,k) = F_orv(i,l_njv,k) + F_rv (i,l_njv,k)
F_orv(i,l_njv,k) = ZERO_8
*
wk2(i,l_njv-1) = - c8_8 * Cori_fcorv_8(i,l_njv) *
% ( inuvl_wyyv3_8(l_njv,1)*F_rv(i,l_njv,k) ) + wk2(i,l_njv-1)
wk2(i,l_njv) = - c8_8 * Cori_fcorv_8(i,l_njv) *
% ( inuvl_wyyv3_8(l_njv,2)*F_rv(i,l_njv,k) ) + wk2(i,l_njv)
*
wk2(i,l_njv+1) = - c8_8 * Cori_fcorv_8(i,l_njv) *
% ( inuvl_wyyv3_8(l_njv,3)*F_rv(i,l_njv,k) ) + wk2(i,l_njv+1)
*
F_fi(i,l_njv+1,k)= - c2_8 *wk1m(i,l_njv)*( F_rv(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + F_fi(i,l_njv+1,k)
F_fi(i,l_njv,k) = - c2_8 *wk1m(i,l_njv)*( - F_rv(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + F_fi(i,l_njv,k)
*
wk1 (i,l_njv) = - c2_8 * F_rv(i,l_njv,k)*( F_fim(i,l_njv+1,k)- F_fim(i,l_njv,k))
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + wk1 (i,l_njv)
*
F_q(i,l_njv+1,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_rv(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + F_q(i,l_njv+1,k)
*
F_q(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_rv(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + F_q(i,l_njv,k)
*
F_t(i,l_njv,k) = - c1_8 *( ( 1. - intuv_c0yyv_8(l_njv) )
% * F_rv(i,l_njv,k) )
% * ( F_qm(i,l_njv+1,k) - F_qm(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + F_t(i,l_njv,k)
*
F_t(i,l_njv+1,k) = - c1_8 *( intuv_c0yyv_8(l_njv)
% * F_rv(i,l_njv,k) )
% * ( F_qm(i,l_njv+1,k) - F_qm(i,l_njv,k) )
% * Geomg_cyv2_8(l_njv)*Geomg_invhsy_8(l_njv) + F_t(i,l_njv+1,k)
*
F_v (i,l_njv,k) = - aaa_8*F_rv(i,l_njv,k) + F_v(i,l_njv,k)
F_rv(i,l_njv,k) = ZERO_8
*
end do
endif
*
if (l_south) then
do i = in,i0,-1
*
F_rv (i,1,k) = F_orv(i,1,k) + F_rv (i,1,k)
F_orv(i,1,k) = ZERO_8
*
wk2(i,1) = - c8_8 * Cori_fcorv_8(i,1)
% * (inuvl_wyyv3_8(1,2)*F_rv(i,1,k)) + wk2(i,1)
wk2(i,2) = - c8_8 * Cori_fcorv_8(i,1)
% * (inuvl_wyyv3_8(1,3)*F_rv(i,1,k)) + wk2(i,2)
wk2(i,3) = - c8_8 * Cori_fcorv_8(i,1)
% * (inuvl_wyyv3_8(1,4)*F_rv(i,1,k)) + wk2(i,3)
*
F_fi(i,1+1,k) = - c2_8 * wk1m(i,1) * ( F_rv(i,1,k) )
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + F_fi(i,1+1,k)
F_fi(i,1,k) = - c2_8 * wk1m(i,1) * ( - F_rv(i,1,k) )
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + F_fi(i,1,k)
*
wk1 (i,1) = - c2_8 * F_rv(i,1,k) * ( F_fim(i,1+1,k) - F_fim(i,1,k) )
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + wk1 (i,1)
*
F_q(i,1+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_rv(i,1,k) )
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + F_q(i,1+1,k)
*
F_q(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_rv(i,1,k) )
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + F_q(i,1,k)
*
F_t(i,1,k) = - c1_8 *( ( 1. - intuv_c0yyv_8(1) )* F_rv(i,1,k))
% * (F_qm(i,1+1,k)-F_qm(i,1,k))
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + F_t(i,1,k)
*
F_t(i,1+1,k)= - c1_8 *( intuv_c0yyv_8(1) * F_rv(i,1,k))
% * (F_qm(i,1+1,k)-F_qm(i,1,k))
% * Geomg_cyv2_8(1)*Geomg_invhsy_8(1) + F_t(i,1+1,k)
*
F_v (i,1,k) = - aaa_8* F_rv(i,1,k) + F_v(i,1,k)
F_rv(i,1,k) = ZERO_8
end do
endif
*
endif
*
* ADJ of
* Adding coriolis factor to Rv
do j = jn,j0,-1
do i = in,i0,-1
*
F_rv (i,j,k) = F_orv(i,j,k) + F_rv (i,j,k)
F_orv(i,j,k) = ZERO_8
*
wk2(i,j-1) = - c8_8 * Cori_fcorv_8(i,j) *
% (inuvl_wyyv3_8(j,1)*F_rv(i,j,k)) + wk2(i,j-1)
*
wk2(i,j) = - c8_8 * Cori_fcorv_8(i,j) *
% (inuvl_wyyv3_8(j,2)*F_rv(i,j,k)) + wk2(i,j )
*
wk2(i,j+1) = - c8_8 * Cori_fcorv_8(i,j) *
% (inuvl_wyyv3_8(j,3)*F_rv(i,j,k)) + wk2(i,j+1)
wk2(i,j+2) = - c8_8 * Cori_fcorv_8(i,j) *
% (inuvl_wyyv3_8(j,4)*F_rv(i,j,k)) + wk2(i,j+2)
*
F_fi(i,j+1,k) = - c2_8 *wk1m(i,j)*( F_rv(i,j,k) )
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + F_fi(i,j+1,k)
F_fi(i,j,k) = - c2_8 *wk1m(i,j)*( - F_rv(i,j,k) )
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + F_fi(i,j,k)
*
wk1(i,j) = - c2_8 * F_rv(i,j,k)*( F_fim(i,j+1,k) - F_fim(i,j,k) )
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + wk1(i,j)
*
F_q(i,j+1,k) = - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_tm(i,j,k)
% + intuv_c0yyv_8(j) *F_tm(i,j+1,k) )
% * ( F_rv(i,j,k) )
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + F_q(i,j+1,k)
*
F_q(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_rv(i,j,k) )
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + F_q (i,j,k)
*
F_t(i,j,k) = - c1_8 *( ( 1. - intuv_c0yyv_8(j) )*F_rv(i,j,k) )
% * (F_qm(i,j+1,k)-F_qm(i,j,k))
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + F_t(i,j,k)
*
F_t(i,j+1,k) = - c1_8 *( intuv_c0yyv_8(j) *F_rv(i,j,k) )
% * (F_qm(i,j+1,k)-F_qm(i,j,k))
% * Geomg_cyv2_8(j)*Geomg_invhsy_8(j) + F_t(i,j+1,k)
*
F_v (i,j,k) = - aaa_8* F_rv(i,j,k) + F_v(i,j,k)
F_rv(i,j,k) = ZERO_8
*
end do
end do
*
* 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 = jnn,j00,-1
do i = inn,i00,-1
*
* ADJ
* ---
F_u(i-2,j,k) = inuvl_wxux3_8(i,1)*wk2(i,j) + F_u(i-2,j,k)
F_u(i-1,j,k) = inuvl_wxux3_8(i,2)*wk2(i,j) + F_u(i-1,j,k)
F_u(i ,j,k) = inuvl_wxux3_8(i,3)*wk2(i,j) + F_u(i ,j,k)
F_u(i+1,j,k) = inuvl_wxux3_8(i,4)*wk2(i,j) + F_u(i+1,j,k)
wk2(i,j) = ZERO_8
end do
end do
*
endif
*
if (.not. Schm_hydro_L) then
do j = jn, j0,-1
do i = in, i0,-1
*
* ADJ
* ---
F_mu(i,j ,k) = ( 1. - intuv_c0yyv_8(j) )* wk1 (i,j) + F_mu(i,j ,k)
F_mu(i,j+1,k) = intuv_c0yyv_8(j) * wk1 (i,j) + F_mu(i,j+1,k)
wk1 (i,j) = ZERO_8
*
end do
end do
endif
*
*ADJ of
*****************************
* 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))
*
end do
end do
endif
*
if ( abs(c8_8) .lt. 1.0e-6 ) then
do j= jn,j0,-1
do i= in,i0,-1
*
* ADJ
* ---
F_ru (i,j,k) = F_oru (i,j,k) + F_ru (i,j,k)
F_oru(i,j,k) = ZERO_8
*
F_fi(i+1,j,k) = -c2_8 * wk1m(i,j)*( F_ru(i,j,k) )
% * inv_Geomg_hx_8(i) + F_fi(i+1,j,k)
*
F_fi(i,j,k) = -c2_8 * wk1m(i,j)*( - F_ru(i,j,k) )
% * inv_Geomg_hx_8(i) + F_fi(i,j,k)
*
wk1 (i,j) = - c2_8 * F_ru(i,j,k)*( F_fim(i+1,j,k) - F_fim(i,j,k) ) * inv_Geomg_hx_8(i)
% + wk1 (i,j)
*
F_t (i,j,k) = - c1_8 * ( ( 1. - intuv_c0xxu_8(i) )*F_ru(i,j,k) )
% * ( F_qm(i+1,j,k)-F_qm(i,j,k) )
% * inv_Geomg_hx_8(i) + F_t(i,j,k)
*
F_t (i+1,j,k) = - c1_8 * ( intuv_c0xxu_8(i) *F_ru(i,j,k) )
% * ( F_qm(i+1,j,k)-F_qm(i,j,k) )
% * inv_Geomg_hx_8(i) + F_t(i+1,j,k)
*
F_q (i+1,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_ru(i,j,k) )
% * inv_Geomg_hx_8(i) + F_q(i+1,j,k)
*
F_q (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_ru(i,j,k) )
% * inv_Geomg_hx_8(i) + F_q(i,j,k)
*
F_u (i,j,k) = - aaa_8 * F_ru(i,j,k)+ F_u(i,j,k)
F_ru(i,j,k) = ZERO_8
*
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
*
* 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
*
* ADJ of
* Adding coriolis factor to Ru
do j= jn,j0,-1
do i= in,i0,-1
F_ru (i,j,k) = F_oru(i,j,k) + F_ru (i,j,k)
F_oru(i,j,k) = ZERO_8
*
wk2(i-1,j) = c8_8 * Cori_fcoru_8(i,j) *
% (inuvl_wxxu3_8(i,1)*F_ru(i,j,k)) + wk2(i-1,j)
*
wk2(i,j) = c8_8 * Cori_fcoru_8(i,j) *
% (inuvl_wxxu3_8(i,2)*F_ru(i,j,k)) + wk2(i ,j)
*
wk2(i+1,j) = c8_8 * Cori_fcoru_8(i,j) *
% (inuvl_wxxu3_8(i,3)*F_ru(i,j,k)) + wk2(i+1,j)
wk2(i+2,j) = c8_8 * Cori_fcoru_8(i,j) *
% (inuvl_wxxu3_8(i,4)*F_ru(i,j,k)) + wk2(i+2,j)
*
F_fi(i+1,j,k)= - c2_8 *wk1m(i,j) * ( F_ru(i,j,k) ) * inv_Geomg_hx_8(i)
% + F_fi(i+1,j,k)
*
F_fi(i,j,k) = - c2_8 *wk1m(i,j) * ( - F_ru(i,j,k) ) * inv_Geomg_hx_8(i)
% + F_fi(i,j,k)
*
wk1(i,j) = - c2_8 *F_ru(i,j,k)*( F_fim(i+1,j,k) - F_fim(i,j,k) ) * inv_Geomg_hx_8(i) + wk1(i,j)
*
F_q(i+1,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_ru(i,j,k) ) * inv_Geomg_hx_8(i) + F_q (i+1,j,k)
*
F_q(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_ru(i,j,k) ) * inv_Geomg_hx_8(i) + F_q (i,j,k)
*
F_t(i,j,k) = - c1_8 *( ( 1. - intuv_c0xxu_8(i) )* F_ru(i,j,k) )
% * ( F_qm(i+1,j,k) - F_qm(i,j,k) ) * inv_Geomg_hx_8(i) + F_t(i,j,k)
*
F_t(i+1,j,k) = - c1_8 *( intuv_c0xxu_8(i) * F_ru(i,j,k) )
% * ( F_qm(i+1,j,k) - F_qm(i,j,k) ) * inv_Geomg_hx_8(i) + F_t(i+1,j,k)
*
F_u (i,j,k) = - aaa_8* F_ru(i,j,k) + F_u(i,j,k)
F_ru(i,j,k) = ZERO_8
*
end do
end do
*
* 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
*
if (.not.G_lam) then
if (l_north) then
do i = inn,i00,-1
*
* ADJ
* ---
F_v(i,jnn-1,k) = inuvl_wyvy3_8(jnn+1,1) * wk2(i,jnn+1) + F_v(i,jnn-1,k)
F_v(i,jnn ,k) = inuvl_wyvy3_8(jnn+1,2) * wk2(i,jnn+1) + F_v(i,jnn ,k)
F_v(i,jnn+1,k) = inuvl_wyvy3_8(jnn+1,3) * wk2(i,jnn+1) + F_v(i,jnn+1,k)
wk2(i,jnn+1) = ZERO_8
F_v(i,jnn ,k) = inuvl_wyvy3_8(jnn+2,1) * wk2(i,jnn+2) + F_v(i,jnn ,k)
F_v(i,jnn+1,k) = inuvl_wyvy3_8(jnn+2,2) * wk2(i,jnn+2) + F_v(i,jnn+1,k)
wk2(i,jnn+2) = ZERO_8
end do
endif
if (l_south) then
do i = inn,i00,-1
*
* ADJ
* ---
F_v(i,j00-2,k) = inuvl_wyvy3_8(j00-1,2) * wk2(i,j00-1)
% + F_v(i,j00-2,k)
F_v(i,j00-1,k) = inuvl_wyvy3_8(j00-1,3) * wk2(i,j00-1)
% + F_v(i,j00-1,k)
F_v(i,j00 ,k) = inuvl_wyvy3_8(j00-1,4) * wk2(i,j00-1)
% + F_v(i,j00 ,k)
wk2(i,j00-1) = ZERO_8
*
F_v(i,j00-2,k) = inuvl_wyvy3_8(j00-2,3) * wk2(i,j00-2)
% + F_v(i,j00-2,k)
F_v(i,j00-1,k) = inuvl_wyvy3_8(j00-2,4) * wk2(i,j00-2)
% + F_v(i,j00-1,k)
wk2(i,j00-2) = ZERO_8
end do
endif
*
endif
*
do j = jnn,j00,-1
do i = inn,i00,-1
*
* ADJ
* ---
F_v(i,j+1,k) = inuvl_wyvy3_8(j,4) * wk2(i,j) + F_v(i,j+1,k)
F_v(i,j ,k) = inuvl_wyvy3_8(j,3) * wk2(i,j) + F_v(i,j ,k)
F_v(i,j-1,k) = inuvl_wyvy3_8(j,2) * wk2(i,j) + F_v(i,j-1,k)
F_v(i,j-2,k) = inuvl_wyvy3_8(j,1) * wk2(i,j) + F_v(i,j-2,k)
wk2(i,j) = ZERO_8
*
end do
end do
*
endif
if (.not. Schm_hydro_L) then
do j = jn,j0,-1
do i = in,i0,-1
*
* ADJ
* ---
F_mu(i ,j,k) = ( 1. - intuv_c0xxu_8(i) )* wk1(i,j) + F_mu(i ,j,k)
F_mu(i+1,j,k) = intuv_c0xxu_8(i) * wk1(i,j) + F_mu(i+1,j,k)
wk1 (i, j) = ZERO_8
*
end do
end do
endif
*
1002 continue
!$omp enddo
*
* ADJ of
* Exchange haloes for derivatives & interpolation
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
!$omp single
*
call rpn_comm_adj_halo( F_fi,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
call rpn_comm_adj_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_adj_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_adj_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_adj_halo( F_u, LDIST_DIM,l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* Zero F_fi,F_q,F_t,F_v,F_u halo
* -------------------------
call v4d_zerohalo ( F_fi,l_ni, l_nj, LDIST_DIM, l_nk)
call v4d_zerohalo ( F_q, l_ni, l_nj, LDIST_DIM, l_nk)
call v4d_zerohalo ( F_t, l_ni, l_nj, LDIST_DIM, l_nk)
call v4d_zerohalo ( F_v, l_ni, l_njv,LDIST_DIM, l_nk)
call v4d_zerohalo ( F_u, l_niu,l_nj, LDIST_DIM, l_nk)
*
!$omp end single
*
!$omp end parallel
*
return
end