!-------------------------------------- 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 adw_setint_tl - TLM of adw_setint
*
#include "model_macros_f.h"
*
subroutine adw_setint_tl ( F_n, 5
% F_capx, F_xgg, F_xdd,
% F_capy, F_ygg, F_ydd,
% F_capz, F_cz,
% F_x, F_y, F_z,
% F_nm,
% F_capxm,F_xggm,F_xddm,
% F_capym,F_yggm,F_yddm,
% F_capzm,F_czm,
% F_xm, F_ym, F_zm,
% F_h_L, F_z_L, F_lin_L, F_num,i0,in,j0,jn,kn)
*
implicit none
*
integer F_num, F_n(F_num),i0,in,j0,jn,kn
*
real F_capx(F_num), F_xgg(F_num), F_xdd(F_num)
real F_capy(F_num), F_ygg(F_num), F_ydd(F_num)
real F_capz(F_num), F_cz (F_num)
real F_x (F_num), F_y (F_num), F_z (F_num)
*
logical F_h_L, F_z_L, F_lin_L
*
integer F_nm(F_num)
real F_capxm(F_num), F_xggm(F_num), F_xddm(F_num)
real F_capym(F_num), F_yggm(F_num), F_yddm(F_num)
real F_capzm(F_num), F_czm (F_num)
real F_xm (F_num), F_ym (F_num), F_zm (F_num)
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_20 - Tanguay M. - Correction for haloy.gt.2
*
*language
* fortran 77
*
*object
* see id section
*
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* | | |
* F_n | positions in the 3D volume of interpolation | o |
* | boxes | |
* | | |
* F_capx | \ | o |
* F_xgg | precomputed displacements and interpolation | o |
* F_xdd | / terms along the x-direction | o |
* | | |
* F_capy | \ | o |
* F_ygg | precomputed displacements and interpolation | o |
* F_ydd | / terms along the y-direction | o |
* | | |
* F_capz | \ precomputed displacements and interpolation | o |
* F_cz | / terms along the z-direction | o |
* | | |
* F_x | x coordinate of upstream position | i |
* F_y | y coordinate of upstream position | i |
* F_z | z coordinate of upstream position | i |
* | | |
* F_h_L | switch: .true. :compute horizontal parameters | i |
* F_z_L | switch: .true. :compute vertical parameters | i |
* F_lin_L | switch: .true. :compute interpolation parameters| i |
* | only for linear interpolation | |
* | | |
* F_num | number of points to treat | i |
*______________|_________________________________________________|_____|
*implicits
#include "glb_ld.cdk"
#include "adw.cdk"
*
************************************************************************
integer n, ii, jj, kk, ij, nijag, nij,i, j, k
real*8 prd_8, prdt_8
real*8 prdm_8,prdtm_8
*
nij = l_ni * l_nj
nijag = Adw_nit * Adw_njt
************************************************************************
*
!$omp parallel private(n,prd_8,prdm_8,ii,prdt_8,prdtm_8,jj,kk,ij)
*
if ( F_h_L .and. F_z_L ) then
************************************************************************
if ( F_lin_L ) then
!$omp do
do k=1,kn
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_xm(n))
ii = ( prdm_8 - Adw_x00_8 ) * Adw_ovdx_8
ii = Adw_lcx( ii+1 ) + 1
*
ii = max(2,ii)
ii = min(ii,G_ni+2*Adw_halox-2)
*
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
if ( prdtm_8 .lt. 0.0 ) then
ii = max(2,ii - 1)
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
endif
F_capxm(n) = prdtm_8 * Adw_dix_8(ii)
*
* TLM
* ---
prd_8 = dble(F_x(n))
prdt_8 = prd_8
F_capx(n) = prdt_8 * Adw_dix_8(ii)
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_ym(n))
jj = ( prdm_8 - Adw_y00_8 ) * Adw_ovdy_8
jj = Adw_lcy( jj+1 ) + 1
*
jj = max(Adw_haloy,jj)
jj = min(jj,G_nj+Adw_haloy)
*
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
if ( prdtm_8 .lt. 0.0 ) then
jj = max(Adw_haloy,jj - 1)
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
endif
F_capym(n) = prdtm_8 * Adw_diy_8(jj)
*
* TLM
* ---
prd_8 = dble(F_y(n))
prdt_8 = prd_8
F_capy(n) = prdt_8 * Adw_diy_8(jj)
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_zm(n))
kk = ( prdm_8 - Adw_z00_8 ) * Adw_ovdz_8
kk = Adw_lcz( kk+1 )
prdm_8 = prdm_8 - Adw_bsz_8(kk)
if ( prdm_8 .lt. 0.0 ) kk = kk - 1
F_capzm(n) = prdm_8 * Adw_diz_8(kk)
if ( prdm_8 .lt. 0.0 ) F_capzm(n) = 1.0 + F_capzm(n)
ij = (jj-Adw_int_j_off-1)*Adw_nit + (ii-Adw_int_i_off)
F_nm(n) = kk*nijag + ij
*
* TLM
* ---
prd_8 = dble(F_z(n))
C prd_8 = prd_8
F_capz(n) = prd_8 * Adw_diz_8(kk)
F_n(n) = 0.
*
enddo
enddo
enddo
!$omp enddo
else
!$omp do
do k=1,kn
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_xm(n))
ii = ( prdm_8 - Adw_x00_8 ) * Adw_ovdx_8
ii = Adw_lcx( ii+1 ) + 1
*
ii = max(2,ii)
ii = min(ii,G_ni+2*Adw_halox-2)
*
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
if ( prdtm_8 .lt. 0.0 ) then
ii = max(2,ii - 1)
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
endif
F_capxm(n) = prdtm_8 * Adw_dix_8(ii)
*
* TLM
* ---
prd_8 = dble(F_x(n))
prdt_8 = prd_8
F_capx(n) = prdt_8 * Adw_dix_8(ii)
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_ym(n))
jj = ( prdm_8 - Adw_y00_8 ) * Adw_ovdy_8
jj = Adw_lcy( jj+1 ) + 1
*
jj = max(Adw_haloy,jj)
jj = min(jj,G_nj+Adw_haloy)
*
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
if ( prdtm_8 .lt. 0.0 ) then
jj = max(Adw_haloy,jj - 1)
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
endif
F_capym(n) = prdtm_8 * Adw_diy_8(jj)
*
* TLM
* ---
prd_8 = dble(F_y(n))
prdt_8 = prd_8
F_capy(n) = prdt_8 * Adw_diy_8(jj)
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_zm(n))
kk = ( prdm_8 - Adw_z00_8 ) * Adw_ovdz_8
kk = Adw_lcz( kk+1 )
prdm_8 = prdm_8 - Adw_bsz_8(kk)
if ( prdm_8 .lt. 0.0 ) kk = kk - 1
F_capzm(n) = prdm_8 * Adw_diz_8(kk)
if ( prdm_8 .lt. 0.0 ) F_capzm(n) = 1.0 + F_capzm(n)
*
F_xggm(n) = Adw_dlx_8(ii-1) * Adw_dix_8(ii)
F_xddm(n) = Adw_dlx_8(ii+1) * Adw_dix_8(ii)
F_yggm(n) = Adw_dly_8(jj-1) * Adw_diy_8(jj)
F_yddm(n) = Adw_dly_8(jj+1) * Adw_diy_8(jj)
F_czm (n) = (F_capzm(n)-1.0)*F_capzm(n)*Adw_dbz_8(kk)
ij = (jj-Adw_int_j_off-1)*Adw_nit + (ii-Adw_int_i_off)
F_nm(n) = kk*nijag + ij
*
* TLM
* ---
prd_8 = dble(F_z(n))
C prd_8 = prd_8
F_capz(n) = prd_8 * Adw_diz_8(kk)
F_xgg(n) = 0.
F_xdd(n) = 0.
F_ygg(n) = 0.
F_ydd(n) = 0.
F_cz (n) = (F_capzm(n)-1.0)*F_capz (n)*Adw_dbz_8(kk) +
% (F_capz (n) )*F_capzm(n)*Adw_dbz_8(kk)
F_n(n) = 0.
*
enddo
enddo
enddo
!$omp enddo
endif
************************************************************************
elseif (F_h_L) then
************************************************************************
if ( F_lin_L ) then
!$omp do
do k=1,kn
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
kk = ( F_nm(n) - (mod ( F_nm(n), nijag ))) / nijag
prdm_8 = dble(F_xm(n))
ii = ( prdm_8 - Adw_x00_8 ) * Adw_ovdx_8
ii = Adw_lcx( ii+1 ) + 1
*
ii = max(2,ii)
ii = min(ii,G_ni+2*Adw_halox-2)
*
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
if ( prdtm_8 .lt. 0.0 ) then
ii = max(2,ii - 1)
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
endif
F_capxm(n) = prdtm_8 * Adw_dix_8(ii)
*
* TLM
* ---
C kk = ( F_n(n) - (mod ( F_n(n), nijag ))) / nijag
prd_8 = dble(F_x(n))
prdt_8 = prd_8
F_capx(n) = prdt_8 * Adw_dix_8(ii)
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_ym(n))
jj = ( prdm_8 - Adw_y00_8 ) * Adw_ovdy_8
jj = Adw_lcy( jj+1 ) + 1
*
jj = max(Adw_haloy,jj)
jj = min(jj,G_nj+Adw_haloy)
*
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
if ( prdtm_8 .lt. 0.0 ) then
jj = max(Adw_haloy,jj - 1)
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
endif
F_capym(n) = prdtm_8 * Adw_diy_8(jj)
ij = (jj-Adw_int_j_off-1)*Adw_nit + (ii-Adw_int_i_off)
F_nm(n) = kk*nijag + ij
*
* TLM
* ---
prd_8 = dble(F_y(n))
prdt_8 = prd_8
F_capy(n) = prdt_8 * Adw_diy_8(jj)
F_n(n) = 0.
*
enddo
enddo
enddo
!$omp enddo
else
!$omp do
do k=1,kn
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
kk = ( F_nm(n) - (mod ( F_nm(n), nijag ))) / nijag
prdm_8 = dble(F_xm(n))
ii = ( prdm_8 - Adw_x00_8 ) * Adw_ovdx_8
ii = Adw_lcx( ii+1 ) + 1
*
ii = max(2,ii)
ii = min(ii,G_ni+2*Adw_halox-2)
*
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
if ( prdtm_8 .lt. 0.0 ) then
ii = max(2,ii - 1)
prdtm_8 = prdm_8 - Adw_bsx_8(ii)
endif
F_capxm(n) = prdtm_8 * Adw_dix_8(ii)
*
* TLM
* ---
C kk = ( F_n(n) - (mod ( F_n(n), nijag ))) / nijag
prd_8 = dble(F_x(n))
prdt_8 = prd_8
F_capx(n) = prdt_8 * Adw_dix_8(ii)
*
* TRAJECTORY
* ----------
prdm_8 = dble(F_ym(n))
jj = ( prdm_8 - Adw_y00_8 ) * Adw_ovdy_8
jj = Adw_lcy( jj+1 ) + 1
*
jj = max(Adw_haloy,jj)
jj = min(jj,G_nj+Adw_haloy)
*
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
if ( prdtm_8 .lt. 0.0 ) then
jj = max(Adw_haloy,jj - 1)
prdtm_8 = prdm_8 - Adw_bsy_8(jj)
endif
F_capym(n) = prdtm_8 * Adw_diy_8(jj)
F_xggm(n) = Adw_dlx_8(ii-1) * Adw_dix_8(ii)
F_xddm(n) = Adw_dlx_8(ii+1) * Adw_dix_8(ii)
F_yggm(n) = Adw_dly_8(jj-1) * Adw_diy_8(jj)
F_yddm(n) = Adw_dly_8(jj+1) * Adw_diy_8(jj)
ij = (jj-Adw_int_j_off-1)*Adw_nit + (ii-Adw_int_i_off)
F_nm(n) = kk*nijag + ij
*
* TLM
* ---
prd_8 = dble(F_y(n))
prdt_8 = prd_8
F_capy(n) = prdt_8 * Adw_diy_8(jj)
F_xgg(n) = 0.
F_xdd(n) = 0.
F_ygg(n) = 0.
F_ydd(n) = 0.
F_n(n) = 0.
*
enddo
enddo
enddo
!$omp enddo
endif
************************************************************************
elseif (F_z_L) then
************************************************************************
if ( F_lin_L ) then
!$omp do
do k=1,kn
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
ij = mod ( F_nm(n), nijag )
prdm_8 = dble(F_zm(n))
kk = ( prdm_8 - Adw_z00_8 ) * Adw_ovdz_8
kk = Adw_lcz( kk+1 )
prdm_8 = prdm_8 - Adw_bsz_8(kk)
if ( prdm_8 .lt. 0.0 ) kk = kk - 1
F_capzm(n) = prdm_8 * Adw_diz_8(kk)
if ( prdm_8 .lt. 0.0 ) F_capzm(n) = 1.0 + F_capzm(n)
F_nm(n) = kk*nijag + ij
*
* TLM
* ---
prd_8 = dble(F_z(n))
C prd_8 = prd_8
F_capz(n) = prd_8 * Adw_diz_8(kk)
F_n(n) = 0.
*
enddo
enddo
enddo
!$omp enddo
else
!$omp do
do k=1,kn
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
ij = mod ( F_nm(n), nijag )
prdm_8 = dble(F_zm(n))
kk = ( prdm_8 - Adw_z00_8 ) * Adw_ovdz_8
kk = Adw_lcz( kk+1 )
prdm_8 = prdm_8 - Adw_bsz_8(kk)
if ( prdm_8 .lt. 0.0 ) kk = kk - 1
F_capzm(n) = prdm_8 * Adw_diz_8(kk)
if ( prdm_8 .lt. 0.0 ) F_capzm(n) = 1.0 + F_capzm(n)
F_czm(n) = (F_capzm(n)-1.0)*F_capzm(n)*Adw_dbz_8(kk)
F_nm(n) = kk*nijag + ij
*
* TLM
* ---
prd_8 = dble(F_z(n))
C prd_8 = prd_8
F_capz(n) = prd_8 * Adw_diz_8(kk)
F_cz(n) = (F_capzm(n)-1.0)*F_capz (n)*Adw_dbz_8(kk) +
% (F_capz (n) )*F_capzm(n)*Adw_dbz_8(kk)
F_n(n) = 0.
*
enddo
enddo
enddo
!$omp enddo
endif
************************************************************************
endif
!$omp end parallel
************************************************************************
*
return
end