!-------------------------------------- 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_ad - ADJ of prep_2_tl
*
#include "model_macros_f.h"
*
subroutine prep_2_ad ( F_ru, F_rv, F_ruw1, F_ruw2, F_rvw1, F_rvw2, 1,5
$ 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_ruw2m, F_rvw2m,
$ F_xct1m, F_yct1m, F_zct1m,
*
$ 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_ruw2m(DIST_SHAPE,Nk), F_rvw2m(DIST_SHAPE,Nk),
% F_xct1m (ni,nj,Nk), F_yct1m (ni,nj,Nk), F_zct1m (ni,nj,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
* -------------------------------------------------------------
*
*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, 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*8 cxm_8, cym_8, czm_8, rxm_8, rym_8, rzm_8, mumum_8
real*8 cxm2_8,cym2_8,czm2_8,rxm2_8,rym2_8,rzm2_8,mumum2_8,mumum3_8
real*8 rxm3_8,rym3_8,rzm3_8,inv_cxyzm2_8,inv_cxyzm22_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
*
!$omp parallel private (x_8,y_8,z_8,mumu_8,rx_8,ry_8,rz_8,
!$omp% cx_8,cy_8,cz_8,a1_8,a2_8,b1_8,b2_8,b3_8,
!$omp% mumum_8,rxm_8,rym_8,rzm_8,cxm_8,cym_8,czm_8,
!$omp% cxm2_8,cym2_8,czm2_8,i0,in,j0,jn,
!$omp% rxm2_8,rym2_8,rzm2_8,i00,inn,j00,jnn,
!$omp% mumum2_8,mumum3_8,i,j,k,
!$omp% rxm3_8,rym3_8,rzm3_8,b1ob0_8,tot_8,
!$omp% inv_cxyzm2_8,inv_cxyzm22_8)
*
* ----------------------------
* Zero adjoint local variables
* ----------------------------
cx_8 = ZERO_8
cy_8 = ZERO_8
cz_8 = ZERO_8
*
rx_8 = ZERO_8
ry_8 = ZERO_8
rz_8 = ZERO_8
*
mumu_8 = ZERO_8
*
* -------------------------
* START ADJOINT CALCULATION
* -------------------------
*
****************************************
* The linear RHS of Helmholtz equation *
****************************************
!$omp do
do j= 1+pil_s, l_nj-pil_n
*
k = l_nk
*
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 i= 1+pil_w, l_ni-pil_e
*
* ADJ
* ---
F_wijk2(i,j,k-1) = b1_8* F_rhell(i,j,k) + F_wijk2(i,j,k-1)
F_wijk2(i,j,k ) = b2_8* F_rhell(i,j,k) + F_wijk2(i,j,k )
F_wijk1(i,j,k-1) = a1_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k-1)
F_wijk1(i,j,k ) = a1_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k )
F_rhell(i,j,k ) = ZERO_8
*
end do
do k=l_nk-1,2,-1
*
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 i= 1+pil_w, l_ni-pil_e
*
* ADJ
* ---
F_wijk2(i,j,k-1) = b1_8* F_rhell(i,j,k) + F_wijk2(i,j,k-1)
F_wijk2(i,j,k+1) = - b3_8* F_rhell(i,j,k) + F_wijk2(i,j,k+1)
F_wijk1(i,j,k ) = a2_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k )
F_wijk1(i,j,k+1) = a2_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k+1)
F_wijk1(i,j,k-1) = a1_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k-1)
F_wijk1(i,j,k ) = a1_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k )
F_rhell(i,j,k ) = ZERO_8
*
end do
*
end do
*
k = 1
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 i= 1+pil_w, l_ni-pil_e
*
* ADJ
* ---
F_wijk2(i,j,k ) = - b2_8* F_rhell(i,j,k) + F_wijk2(i,j,k )
F_wijk2(i,j,k+1) = - b3_8* F_rhell(i,j,k) + F_wijk2(i,j,k+1)
F_wijk1(i,j,k ) = a2_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k )
F_wijk1(i,j,k+1) = a2_8*( F_rhell(i,j,k) ) + F_wijk1(i,j,k+1)
F_rhell(i,j,k ) = ZERO_8
*
end do
*
end do
!$omp enddo
*
**************************************
* ADJ of
* 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 do
do k=1,l_nk
*
* ADJ of
* Combination of divergence & continuity equations
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
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
*
* ADJ
* ---
F_r3 (i,j,k) = b2_8* F_wijk2(i,j,k) + F_r3 (i,j,k)
*
F_r3p(i,j,k) = b1_8* F_wijk1(i,j,k) + F_r3p(i,j,k)
*
F_r3 (i,j,k) = F_r3p (i,j,k) + F_r3 (i,j,k)
F_rth(i,j,k) = - eps_8* F_r3p (i,j,k) + F_rth(i,j,k)
F_r3p(i,j,k) = ZERO_8
*
F_rw (i,j,k) = a1_8* F_r3 (i,j,k) + F_rw (i,j,k)
F_rvv(i,j,k) = a2_8* F_r3 (i,j,k) + F_rvv(i,j,k)
F_r3 (i,j,k) = ZERO_8
*
C F_rvv(i,j,k) = F_rvv(i,j,k)
*
end do
end do
endif
*
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
*
* ADJ
* ---
F_rth (i,j,k) = b2_8*F_wijk2(i,j,k) + F_rth(i,j,k)
F_wijk2(i,j,k) = ZERO_8
*
F_r1 (i,j,k) = F_wijk1(i,j,k) + F_r1 (i,j,k)
F_wijk1(i,j,k) = ZERO_8
*
F_rd (i,j,k) = F_r1(i,j,k) + F_rd (i,j,k)
F_rcn(i,j,k) = - F_r1(i,j,k) /Cstv_tau_8 + F_rcn(i,j,k)
F_r1 (i,j,k) = ZERO_8
*
end do
end do
*
if (G_lam) then
do j= l_nj-pil_n,1+pil_s,-1
do i= l_ni-pil_e,1+pil_w,-1
F_ru(i, j, k) =( F_rd(i,j,k) )/( Geomg_cy2_8(j)*Geomg_hxu_8(i-1) ) + F_ru(i, j, k)
F_ru(i-1,j, k) =(- F_rd(i,j,k) )/( Geomg_cy2_8(j)*Geomg_hxu_8(i-1) ) + F_ru(i-1,j, k)
F_rv(i, j, k) =( F_rd(i,j,k) )* Geomg_invhsyv_8(j-1) + F_rv(i, j, k)
F_rv(i, j-1,k) =(- F_rd(i,j,k) )* Geomg_invhsyv_8(j-1) + F_rv(i, j-1,k)
F_rd(i, j, k) = ZERO_8
end do
end do
else
*
* ADJ
* ---
call caldiv_2_ad ( F_rd(minx,miny,k), F_ru(minx,miny,k),
$ F_rv(minx,miny,k), LDIST_DIM, 1)
*
endif
*
end do
!$omp enddo
*
!$omp single
*
* ADJ of
* Compute the RHS of divergence equation
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 )
!$omp end single
*
!$omp do
do k= 1,l_nk
* Zero F_rv halo
* -------------
call v4d_zerohalo ( F_rv(l_minx,l_miny,k),l_ni,l_njv,LDIST_DIM,1)
*
* Zero F_ru halo
* --------------
call v4d_zerohalo ( F_ru(l_minx,l_miny,k),l_niu,l_nj,LDIST_DIM,1)
*
enddo
!$omp enddo
*
*
**********************************************************
* ADJ of
* Final form of the RHS of horizontal momentum equations *
**********************************************************
* 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 do
do k=1,l_nk
*
* ADJ of
* Add advective & topographic contributions to Ru & Rv
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
if (.not.G_lam) then
if (l_north) then
do i = l_ni,1,-1
*
* ADJ
* ---
F_rvw2(i,l_njv+1,k) = inuvl_wyyv3_8(l_njv,3)* F_rv(i,l_njv,k)
% + F_rvw2(i,l_njv+1,k)
F_rvw2(i,l_njv ,k) = inuvl_wyyv3_8(l_njv,2)* F_rv(i,l_njv,k)
% + F_rvw2(i,l_njv ,k)
F_rvw2(i,l_njv-1,k) = inuvl_wyyv3_8(l_njv,1)* F_rv(i,l_njv,k)
% + F_rvw2(i,l_njv-1,k)
*
end do
endif
*
if (l_south) then
do i = l_ni,1,-1
*
* ADJ
* ---
F_rvw2(i,3,k) = inuvl_wyyv3_8(1,4)*F_rv(i,1,k) + F_rvw2(i,3,k)
F_rvw2(i,2,k) = inuvl_wyyv3_8(1,3)*F_rv(i,1,k) + F_rvw2(i,2,k)
F_rvw2(i,1,k) = inuvl_wyyv3_8(1,2)*F_rv(i,1,k) + F_rvw2(i,1,k)
*
end do
endif
*
endif
*
do j= jnn, j00,-1
do i= inn, i00,-1
*
* ADJ
* ---
F_rvw2(i,j+2,k) = inuvl_wyyv3_8(j,4)*F_rv(i,j,k) + F_rvw2(i,j+2,k)
F_rvw2(i,j+1,k) = inuvl_wyyv3_8(j,3)*F_rv(i,j,k) + F_rvw2(i,j+1,k)
F_rvw2(i,j ,k) = inuvl_wyyv3_8(j,2)*F_rv(i,j,k) + F_rvw2(i,j ,k)
F_rvw2(i,j-1,k) = inuvl_wyyv3_8(j,1)*F_rv(i,j,k) + F_rvw2(i,j-1,k)
*
end do
end do
*
do j= jn,j0,-1
do i= in,i0,-1
*
* ADJ
* ---
F_ruw2(i+2,j,k) = inuvl_wxxu3_8(i,4)*F_ru(i,j,k) + F_ruw2(i+2,j,k)
F_ruw2(i+1,j,k) = inuvl_wxxu3_8(i,3)*F_ru(i,j,k) + F_ruw2(i+1,j,k)
F_ruw2(i ,j,k) = inuvl_wxxu3_8(i,2)*F_ru(i,j,k) + F_ruw2(i ,j,k)
F_ruw2(i-1,j,k) = inuvl_wxxu3_8(i,1)*F_ru(i,j,k) + F_ruw2(i-1,j,k)
*
end do
end do
*
end do
!$omp enddo
*
!$omp single
*
* ADJ
* ---
call rpn_comm_adj_halo( F_rvw2, 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_ruw2, 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 k= 1,l_nk
* Zero F_rvw2,F_ruw2 halo
* -----------------------
call v4d_zerohalo ( F_rvw2(l_minx,l_miny,k),l_ni,l_nj,LDIST_DIM,1)
call v4d_zerohalo ( F_ruw2(l_minx,l_miny,k),l_ni,l_nj,LDIST_DIM,1)
*
enddo
!$omp enddo
*
******************************************************************
* ADJ of
* Metric corrections to the RHS of horizontal momentum equations *
******************************************************************
tot_8 = - FOUR_8*Dcst_omega_8/Cstv_dt_8
b1ob0_8 = Offc_b1_8/Offc_b0_8
*
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 do
do 101 k=l_nk,1,-1
do 101 j= jn,j0,-1
do 101 i= in,i0,-1
*
* ---------------------------------
* START REBUILD TRAJECTORY LOOP 100
* ---------------------------------
*
* 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) )
*
* TRAJECTORY
* ----------
mumum3_8 = mumum_8
if (mumum_8 .GT. ZERO_8) then
mumum3_8 = ONE_8 / mumum_8
endif
*
* TRAJECTORY
* ----------
rzm_8 = F_rvw2m(i,j,k)
rym_8 = mumum3_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 = -mumum3_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)
*
* 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
* ----------
rxm3_8= rxm_8 + ( Grd_rot_8(2,3)*czm_8 - Grd_rot_8(3,3)*cym_8 )*tot_8
rym3_8= rym_8 + ( Grd_rot_8(3,3)*cxm_8 - Grd_rot_8(1,3)*czm_8 )*tot_8
rzm3_8= rzm_8 + ( Grd_rot_8(1,3)*cym_8 - Grd_rot_8(2,3)*cxm_8 )*tot_8
*
else
*
* TRAJECTORY
* ----------
rxm3_8= rxm_8
rym3_8= rym_8
rzm3_8= rzm_8
*
endif
*
* Compute components of c and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* TRAJECTORY
* ----------
cxm2_8 = x_8 + b1ob0_8*F_xct1m(i,j,k)
cym2_8 = y_8 + b1ob0_8*F_yct1m(i,j,k)
czm2_8 = z_8 + b1ob0_8*F_zct1m(i,j,k)
*
* Compute mu and modify (Rx,Ry,Rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* TRAJECTORY
* ----------
inv_cxyzm2_8 = ONE_8/( x_8*cxm2_8+ y_8*cym2_8+ z_8*czm2_8)
inv_cxyzm22_8 = ONE_8/(( x_8*cxm2_8+ y_8*cym2_8+ z_8*czm2_8)**2)
mumum2_8 = - ( x_8*rxm3_8 + y_8*rym3_8 + z_8*rzm3_8 )*inv_cxyzm2_8
rxm2_8 = rxm3_8 + mumum2_8*cxm2_8
rym2_8 = rym3_8 + mumum2_8*cym2_8
rzm2_8 = rzm3_8 + mumum2_8*czm2_8
*
* -------------------------------
* END REBUILD TRAJECTORY LOOP 100
* -------------------------------
*
* ADJ of
* Compute advective contributions on G-grid
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* ADJ
* ---
rz_8 = F_rvw2(i,j,k)
F_rvw1(i,j,k) = - F_rvw2(i,j,k) + F_rvw1(i,j,k)
F_rvw2(i,j,k) = ZERO_8
*
ry_8 = ( x_8* F_ruw2(i,j,k) )
rx_8 = ( - y_8* F_ruw2(i,j,k) )
F_ruw1(i,j,k) = - F_ruw2(i,j,k) + F_ruw1(i,j,k)
F_ruw2(i,j,k) = ZERO_8
*
* ADJ of
* Compute mu and modify (Rx,Ry,Rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* ADJ
* ---
cz_8 = mumum2_8*rz_8
*
cy_8 = mumum2_8*ry_8
*
cx_8 = mumum2_8*rx_8
*
mumu_8 = rx_8*cxm2_8 + (ry_8*cym2_8 + rz_8*czm2_8)
*
rx_8 = - ( x_8*mumu_8 )*inv_cxyzm2_8 + rx_8
ry_8 = - ( y_8*mumu_8 )*inv_cxyzm2_8 + ry_8
rz_8 = - ( z_8*mumu_8 )*inv_cxyzm2_8 + rz_8
cx_8 =
% ( ( x_8*rxm2_8+ y_8*rym2_8+ z_8*rzm2_8)
% *( x_8*mumu_8 ))*inv_cxyzm22_8 + cx_8
cy_8 =
% ( ( x_8*rxm2_8+ y_8*rym2_8+ z_8*rzm2_8)
% *( y_8*mumu_8 ))*inv_cxyzm22_8 + cy_8
cz_8 =
% ( ( x_8*rxm2_8+ y_8*rym2_8+ z_8*rzm2_8)
% *( z_8*mumu_8))*inv_cxyzm22_8 + cz_8
*
* ADJ of
* Compute components of c and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* ADJ
* ---
F_zct1(i,j,k) = b1ob0_8*cz_8 + F_zct1(i,j,k)
F_yct1(i,j,k) = b1ob0_8*cy_8 + F_yct1(i,j,k)
F_xct1(i,j,k) = b1ob0_8*cx_8 + F_xct1(i,j,k)
*
* ADJ of
* 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
*
* ADJ
* ---
cx_8 = ( - Grd_rot_8(2,3)* rz_8 )*tot_8
cx_8 = ( Grd_rot_8(3,3)* ry_8 )*tot_8 + cx_8
*
cy_8 = ( Grd_rot_8(1,3)* rz_8 )*tot_8
cy_8 = ( - Grd_rot_8(3,3)* rx_8 )*tot_8 + cy_8
*
cz_8 = ( - Grd_rot_8(1,3)* ry_8 )*tot_8
cz_8 = ( Grd_rot_8(2,3)* rx_8 )*tot_8 + cz_8
*
else
*
cx_8 = ZERO_8
cy_8 = ZERO_8
cz_8 = ZERO_8
*
endif
*
* ADJ of
* Compute components of (r - r~) and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* ADJ
* ---
F_zct1(i,j,k) = - cz_8 + F_zct1(i,j,k)
*
F_yct1(i,j,k) = - cy_8 + F_yct1(i,j,k)
*
F_xct1(i,j,k) = - cx_8 + F_xct1(i,j,k)
*
*
* ADJ of
* Compute components of r(t0) and put in x, y, z
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* ADJ
* ---
mumu_8 = ry_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 * (
% + F_yct1m(i,j,k)*F_ruw2m(i,j,k)
% + F_xct1m(i,j,k)*F_zct1m(i,j,k)*rzm_8) )
*
* ADJ
* ---
F_xct1 (i,j,k)= -mumum3_8* ( rx_8*F_zct1m(i,j,k)*rzm_8) + F_xct1 (i,j,k)
F_zct1 (i,j,k)= -mumum3_8* ( F_xct1m(i,j,k)*rx_8*rzm_8) + F_zct1 (i,j,k)
rz_8 = -mumum3_8* ( F_xct1m(i,j,k)*F_zct1m(i,j,k)*rx_8) + rz_8
F_yct1 (i,j,k)= -mumum3_8* ( rx_8*F_ruw2m(i,j,k) ) + F_yct1 (i,j,k)
F_ruw2 (i,j,k)= -mumum3_8* ( F_yct1m(i,j,k)*rx_8 ) + F_ruw2 (i,j,k)
*
F_yct1 (i,j,k)= mumum3_8* ( - ry_8*F_zct1m(i,j,k)*rzm_8) + F_yct1 (i,j,k)
F_zct1 (i,j,k)= mumum3_8* ( - F_yct1m(i,j,k)*ry_8*rzm_8) + F_zct1 (i,j,k)
rz_8 = mumum3_8* ( - F_yct1m(i,j,k)*F_zct1m(i,j,k)*ry_8) + rz_8
F_xct1 (i,j,k)= mumum3_8* ( ry_8 *F_ruw2m(i,j,k) ) + F_xct1 (i,j,k)
F_ruw2 (i,j,k)= mumum3_8* ( F_xct1m(i,j,k)* ry_8 ) + F_ruw2 (i,j,k)
*
F_rvw2(i,j,k) = rz_8 + F_rvw2(i,j,k)
*
* ADJ
* ---
if (mumum_8 .GT. ZERO_8) then
mumu_8 = - ( ONE_8 / mumum_8**2) * mumu_8
endif
*
* ADJ of
* Compute (Rx, Ry, Rz) = (rx, ry, rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*
* ADJ
* ---
F_zct1 (i,j,k) = ( ONE_8 + F_zct1m(i,j,k) )*( - mumu_8 ) + F_zct1 (i,j,k)
F_zct1 (i,j,k) = ( mumu_8 )*( ONE_8 - F_zct1m(i,j,k) ) + F_zct1 (i,j,k)
*
101 continue
!$omp enddo
*
!$omp end parallel
*
* __________________________________________________________________
*
return
end