!-------------------------------------- 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 - Add metric corrections to r.h.s. of momentum equations.
* Compute advective contributions on geopotential grid.
* Interpolate advection contribution from geopotential
* grid to wind grids. Update r.h.s with advective
* contributions. Add contribution of topography to rhs
* of momentum equations.
* compute rhs of divergence equation
* compute rhs of combined horizontal equations
* compute the linear rhs of Helmholtz equation
* ( computation and microtasking )
*
#include "model_macros_f.h"
*
subroutine prep_2 ( F_ru, F_rv, F_ruw1, F_ruw2, F_rvw1, F_rvw2, 2,1
$ 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, 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)
*
*author
* Alain Patoine
*
*revision
* v2_00 - Desgagne M. - initial MPI version (from rhs v1_03)
* v2_21 - Lee V. - modification for LAM version
* v2_31 - Desgagne M. - remove stkmemw and switch to adw_*
* v3_00 - Desgagne & Lee - Lam configuration
* v3_10 - Corbeil & Desgagne & Lee - AIXport+Opti+OpenMP
* v3_11 - Gravel S. - modify for theoretical cases
* v3_30 - Desgagne M. - Revision OpenMP
* v3_31 - Desgagne M. - Scope of operator for LAM configs
*
*object
*
*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"
*
*modules
integer i, j, k, i0, j0, in, jn, i00, inn, j00, jnn
real*8 x, y, z, cx, cy, cz, rx, ry, rz, b1ob0, mumu, tot
real*8 a1, a2, b1, b2, b3, ccc, eps, gamma
real*8 zero, one, two, four, half, quarter
parameter( zero=0.0, one=1.0, two=2.0, four=4.0,
$ half=0.5, quarter=.25 )
real wij1(DIST_SHAPE), wij2(DIST_SHAPE)
**
* __________________________________________________________________
*
!$omp parallel private (i, j, k, i0, j0, in, jn, i00, inn, j00, jnn,
!$omp$ x, y, z, cx, cy, cz, rx, ry, rz, b1ob0, mumu,
!$omp$ tot, a1, a2, b1, b2, b3, ccc, eps, gamma)
!$omp$ shared (wij1,wij2)
*
ccc = one/( Dcst_rayt_8*Dcst_rayt_8 )
tot = - four*Dcst_omega_8/Cstv_dt_8
if( Schm_theoc_L ) tot = 0.
b1ob0 = 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
c if (Acid_test_L)then
c if (Lun_debug_L) write (Lun_out,1000)
c call glbstat (F_ruw2,'RUW2',LDIST_DIM,G_nk,6+acid_i0,G_ni-5-acid_in,
c % 6+acid_j0,G_nj-5-acid_jn,1,G_nk)
c call glbstat (F_rvw2,'RVW2',LDIST_DIM,G_nk,6+acid_i0,G_ni-5-acid_in,
c % 6+acid_j0,G_nj-5-acid_jn,1,G_nk)
!$omp do
do 100 k=1,l_nk
do 100 j= j0, jn
do 100 i= i0, in
* Compute components of r(t0) and put in x, y, z
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
y = adw_cy_8(j)
if (G_lam) then
x = adw_cx_8(i) * y
y = adw_sx_8(i) * y
else
x = adw_cx_8(l_i0 - 1 + i) * y
y = adw_sx_8(l_i0 - 1 + i) * y
endif
z = adw_sy_8(j)
* Compute (Rx, Ry, Rz) = (rx, ry, rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mumu = ( one + F_zct1(i,j,k) )*( one - F_zct1(i,j,k) )
if (mumu .GT. zero) mumu = one / mumu
rz = F_rvw2(i,j,k)
ry = mumu * (F_xct1(i,j,k)*F_ruw2(i,j,k)-
$ F_yct1(i,j,k)*F_zct1(i,j,k)*rz)
rx = -mumu * (F_yct1(i,j,k)*F_ruw2(i,j,k)+
$ F_xct1(i,j,k)*F_zct1(i,j,k)*rz)
* Compute components of (r - r~) and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cx = x - F_xct1(i,j,k)
cy = y - F_yct1(i,j,k)
cz = z - F_zct1(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
rx = rx + ( Grd_rot_8(2,3)*cz - Grd_rot_8(3,3)*cy )*tot
ry = ry + ( Grd_rot_8(3,3)*cx - Grd_rot_8(1,3)*cz )*tot
rz = rz + ( Grd_rot_8(1,3)*cy - Grd_rot_8(2,3)*cx )*tot
endif
* Compute components of c and put in cx, cy, cz
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cx = x + b1ob0*F_xct1(i,j,k)
cy = y + b1ob0*F_yct1(i,j,k)
cz = z + b1ob0*F_zct1(i,j,k)
* Compute mu and modify (Rx,Ry,Rz)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mumu = - ( x*rx + y*ry + z*rz )/( x*cx + y*cy + z*cz )
rx = rx + mumu*cx
ry = ry + mumu*cy
rz = rz + mumu*cz
* Compute advective contributions on G-grid
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
F_ruw2(i,j,k) = x*ry - y*rx - F_ruw1(i,j,k)
F_rvw2(i,j,k) = rz - F_rvw1(i,j,k)
100 continue
!$omp enddo
c if (Acid_test_L)then
c if (Lun_debug_L) write (Lun_out,1001)
c call glbstat (F_ruw2,'RUW2',LDIST_DIM,G_nk,6+acid_i0,G_ni-5-acid_in,
c % 6+acid_j0,G_nj-5-acid_jn,1,G_nk)
c call glbstat (F_rvw2,'RVW2',LDIST_DIM,G_nk,6+acid_i0,G_ni-5-acid_in,
c % 6+acid_j0,G_nj-5-acid_jn,1,G_nk)
c endif
**********************************************************
* Final form of the RHS of horizontal momentum equations *
**********************************************************
* Prepare the gradient of topography
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!$omp single
call rpn_comm_xch_halo( F_fis , LDIST_DIM, l_ni,l_nj, 1 ,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo( F_ruw2, 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_rvw2, LDIST_DIM, l_ni, l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
!$omp end single
*
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 j = 1, l_nj
do i = 1, l_ni
wij1(i,j) = ( F_fis(i+1,j) - F_fis(i,j) ) / geomg_hx_8(i)
end do
end do
!$omp enddo
!$omp do
do j = 1, l_njv
do i = 1, l_ni
wij2(i,j) = ( F_fis(i,j+1) - F_fis(i,j) ) *
$ geomg_cyv2_8(j) * geomg_invhsy_8(j)
end do
end do
!$omp enddo
*
!$omp do
do k=1,l_nk
* Add advective & topographic contributions to Ru & Rv
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= j0, jn
do i= i0, in
F_ru(i,j,k) = F_ru(i,j,k) - ccc*wij1(i,j) +
$ inuvl_wxxu3_8(i,1)*F_ruw2(i-1,j,k)
$ + inuvl_wxxu3_8(i,2)*F_ruw2(i ,j,k)
$ + inuvl_wxxu3_8(i,3)*F_ruw2(i+1,j,k)
$ + inuvl_wxxu3_8(i,4)*F_ruw2(i+2,j,k)
end do
end do
*
do j= j00, jnn
do i= i00, inn
F_rv(i,j,k) = F_rv(i,j,k) - ccc*wij2(i,j) +
$ inuvl_wyyv3_8(j,1)*F_rvw2(i,j-1,k)
$ + inuvl_wyyv3_8(j,2)*F_rvw2(i,j ,k)
$ + inuvl_wyyv3_8(j,3)*F_rvw2(i,j+1,k)
$ + inuvl_wyyv3_8(j,4)*F_rvw2(i,j+2,k)
end do
end do
if (.not.G_lam) then
if (l_south) then
do i = 1, l_ni
F_rv(i,1,k) = F_rv(i,1,k) - ccc*wij2(i,1) +
$ inuvl_wyyv3_8(1,2)*F_rvw2(i,1,k)
$ + inuvl_wyyv3_8(1,3)*F_rvw2(i,2,k)
$ + inuvl_wyyv3_8(1,4)*F_rvw2(i,3,k)
end do
endif
if (l_north) then
do i = 1, l_ni
F_rv(i,l_njv,k) = F_rv(i,l_njv,k) - ccc*wij2(i,l_njv) +
$ inuvl_wyyv3_8(l_njv,1)*F_rvw2(i,l_njv-1,k)
$ + inuvl_wyyv3_8(l_njv,2)*F_rvw2(i,l_njv ,k)
$ + inuvl_wyyv3_8(l_njv,3)*F_rvw2(i,l_njv+1,k)
end do
endif
endif
end do
!$omp enddo
**************************************
* Combination of governing equations *
**************************************
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
a1 = one/( Dcst_grav_8 * Cstv_tau_8 )
a2 = Schm_nonhy_8/( Dcst_grav_8**2 * Cstv_tau_8**2 )
b1 = gamma/Cstv_tau_8
b2 = gamma/Cstv_tau_8/Dcst_cappa_8
c if (Acid_test_L)then
c if (Lun_debug_L) write (Lun_out,1002)
c call glbstat (F_ru,'RU0',LDIST_DIM,G_nk,8+acid_i0,G_ni-8-acid_in,
c % 8+acid_j0,G_nj-7-acid_jn,1,G_nk)
c call glbstat (F_rv,'RV0',LDIST_DIM,G_nk,8+acid_i0,G_ni-7-acid_in,
c % 8+acid_j0,G_nj-8-acid_jn,1,G_nk)
c endif
* Compute the RHS of divergence equation
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!$omp single
call rpn_comm_xch_halo( F_ru, 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_rv, 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= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
F_rd(i,j,k) = ( F_ru(i,j,k) - F_ru(i-1,j,k) )
$ /( geomg_cy2_8(j)*geomg_hxu_8(i-1) )
$ + ( F_rv(i,j,k) - F_rv(i,j-1,k) )*geomg_invhsyv_8(j-1)
end do
end do
else
call caldiv_2 ( F_rd(minx,miny,k), F_ru(minx,miny,k),
$ F_rv(minx,miny,k), LDIST_DIM, 1)
endif
* Combination of divergence & continuity equations
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
F_r1(i,j,k) = F_rd(i,j,k) - F_rcn(i,j,k)/Cstv_tau_8
F_wijk1(i,j,k) = F_r1(i,j,k)
F_wijk2(i,j,k) = b2*F_rth(i,j,k)
end do
end do
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
F_rvv(i,j,k) = F_rvv(i,j,k) - F_fis(i,j)/Cstv_tau_8
F_r3 (i,j,k) = a1*F_rw(i,j,k)+ a2*F_rvv(i,j,k)
F_r3p(i,j,k) = F_r3(i,j,k) - eps*F_rth(i,j,k)
F_wijk1(i,j,k) = F_wijk1(i,j,k) + b1*F_r3p(i,j,k)
F_wijk2(i,j,k) = F_wijk2(i,j,k) + b2*F_r3(i,j,k)
end do
end do
endif
end do
!$omp enddo
****************************************
* The linear RHS of Helmholtz equation *
****************************************
!$omp do
do k=1,l_nk
if ( k .eq. 1 ) then
a2 = quarter*Geomg_hz_8(k)
b2 = half*Geomg_z_8(k)
b3 = half*Geomg_z_8(k+1)
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
F_rhell(i,j,k) = a2*( F_wijk1(i,j,k) + F_wijk1(i,j,k+1) )
% - b2*F_wijk2(i,j,k) - b3*F_wijk2(i,j,k+1)
end do
end do
elseif( k .eq. l_nk ) then
a1 = quarter*Geomg_hz_8(k-1)
b1 = half*Geomg_z_8(k-1)
b2 = half*Geomg_z_8(k)
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
F_rhell(i,j,k) = a1*( F_wijk1(i,j,k-1) + F_wijk1(i,j,k) )
% + b1*F_wijk2(i,j,k-1) + b2*F_wijk2(i,j,k)
end do
end do
else
a1 = quarter*Geomg_hz_8(k-1)
a2 = quarter*Geomg_hz_8(k)
b1 = half*Geomg_z_8(k-1)
b3 = half*Geomg_z_8(k+1)
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
F_rhell(i,j,k) = a1*( F_wijk1(i,j,k-1) + F_wijk1(i,j,k) )
% + a2*( F_wijk1(i,j,k) + F_wijk1(i,j,k+1) )
% + b1*F_wijk2(i,j,k-1) - b3*F_wijk2(i,j,k+1)
end do
end do
endif
end do
!$omp enddo
!$omp end parallel
*
c if (Acid_test_L)then
c call glbstat (F_rhell,'Rhl0',LDIST_DIM,G_nk,9+acid_i0,G_ni-8-acid_in,
c % 9+acid_j0,G_nj-8-acid_jn,1,G_nk)
c call glbstat (F_rd,'Rd0',LDIST_DIM,G_nk,9+acid_i0,G_ni-8-acid_in,
c % 9+acid_j0,G_nj-8-acid_jn,1,G_nk)
c endif
*
* __________________________________________________________________
*
1000 format(2X,'Before metric corrections for RUW2,RVW2')
1001 format(2X,'After metric corrections for RUW2,RVW2')
1002 format(2X,'MUST BE GOOD OR ELSE RD and RHELL WILL BE BAD')
1003 format(2X,'MUST BE GOOD OR ELSE RD and RHELL WILL BE BAD')
return
end