!-------------------------------------- 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 v4d_irgdint_3_nw_ad - ADJ of v4d_irgdint_3_nw
*
subroutine v4d_irgdint_3_nw_ad (zo,px,py,npts,ax,ay,cx,cy,zi,i1,i2,j1,j2,nk,jmin,jmax) 7
*
implicit none
*
integer npts,i1,i2,j1,j2,nk,jmin,jmax
real zo(nk,npts),zi(i1:i2,j1:j2,nk),
% px(npts),py(npts),ax(i1:i2),ay(j1:j2),cx(i1:i2,6),cy(j1:j2,6)
*
*author Tanguay M.
*
*revision
* v3_00 - Tanguay M. - initial MPI version
* v3_11 - Tanguay M. - correction for px or py negative
* v3_31 - Tanguay M. - Add OPENMP directives
*
*object
* see id section
*
*Adjoint of
*arguments
* Name I/O Description
*----------------------------------------------------------------
* zo O Interpolated field at positions px,py
* px I Position x in INPUT grid
* py I Position y in INPUT grid
* npts I Number of positions in zo
* zi I Field on INPUT grid
* ax I X axe of INPUT grid
* ay I Y axe of INPUT grid
* cx I AX difference on INPUT grid
* cy I AY difference on INPUT grid
* i1-i2 I Dimension x in INPUT grid
* j1-j2 I Dimension y in INPUT grid
* nk I Dimension z in INPUT grid
* jmin I Lower limit j
* jmax I Higher limit j
*----------------------------------------------------------------
*
integer i,j,n,k
*
real*8 a12_8,a13_8,a14_8,a22_8,a23_8,a24_8,
% a32_8,a33_8,a34_8,a42_8,a43_8,a44_8,
% b12_8,b13_8,b14_8
*
real*8 x1_8,x2_8,x3_8,x4_8,y1_8,y2_8,y3_8,y4_8,
% b1_8,b2_8,b3_8,b4_8,z1_8,z2_8,z3_8,z4_8,
% za_8,zb_8,zc_8,wa_8,wb_8,wc_8,wd_8,
% x_8,y_8
*
real*8, parameter :: ZERO_8 = 0.0
*
!$omp parallel private(i,j,n,x1_8,x2_8,x3_8,x4_8,y1_8,y2_8,y3_8,y4_8,
!$omp$ z1_8,z2_8,z3_8,z4_8,x_8,y_8,
!$omp$ b1_8,b2_8,b3_8,b4_8,
!$omp$ za_8,zb_8,zc_8,wa_8,wb_8,wc_8,wd_8,
!$omp$ a12_8,a13_8,a14_8,
!$omp$ a22_8,a23_8,a24_8,
!$omp$ a32_8,a33_8,a34_8,
!$omp$ a42_8,a43_8,a44_8,
!$omp$ b12_8,b13_8,b14_8)
*
!$omp do
do k=nk,1,-1
do n=npts,1,-1
*
* -----
* FIXED
* -----
i = min(i2-2, max(i1+1, ifix(px(n))))
j = min(jmax-2,max(jmin+1,ifix(py(n))))
*
if (px(n).lt.0.) i = i-1
*
if (py(n).lt.0.) j = j-1
*
x1_8 = ax(i-1)
x2_8 = ax(i)
x3_8 = ax(i+1)
x4_8 = ax(i+2)
*
y1_8=ay(j-1)
y2_8=ay(j)
y3_8=ay(j+1)
y4_8=ay(j+2)
*
x_8 = x2_8 + (x3_8-x2_8)*(px(n)-i)
y_8 = ay(j) + (ay(j+1)-ay(j))*(py(n)-j)
*
* Adjoint of
* interpolation column
* --------------------
b12_8 = (y_8-y1_8)*zo(k,n)
b13_8 = (y_8-y2_8)*b12_8
b14_8 = (y_8-y3_8)*b13_8
*
za_8 = b14_8 * cy(j,4)
zb_8 =-za_8 + b13_8
wa_8 = cy(j,1) * cy(j,2)
wb_8 = cy(j,5) * cy(j,6)
wc_8 = cy(j,3) * cy(j,5)
wd_8 = cy(j,2) * cy(j,3)
*
b1_8 = wa_8 * zb_8
b4_8 = wb_8 * za_8
b2_8 =(wc_8 * za_8 - wd_8 * zb_8) - b1_8
b3_8 =(wd_8 * zb_8 - wc_8 * za_8) - b4_8
*
zc_8 = cy(j,1) * b12_8
*
b2_8 = zc_8 + b2_8
b1_8 =-zc_8 + b1_8 + zo(k,n)
*
zo(k,n)= ZERO_8
*
* Adjoint of
* interpolation row 4
* -------------------
a42_8 = (x_8-x1_8)*b4_8
a43_8 = (x_8-x2_8)*a42_8
a44_8 = (x_8-x3_8)*a43_8
*
za_8 = a44_8* cx(i,4)
zb_8 =-za_8 + a43_8
wa_8 = cx(i,1) * cx(i,2)
wb_8 = cx(i,5) * cx(i,6)
wc_8 = cx(i,3) * cx(i,5)
wd_8 = cx(i,2) * cx(i,3)
*
z1_8 = wa_8 * zb_8
z4_8 = wb_8 * za_8
z2_8 =(wc_8 * za_8 - wd_8 * zb_8) - z1_8
z3_8 =(wd_8 * zb_8 - wc_8 * za_8) - z4_8
*
zc_8 = cx(i,1) * a42_8
*
z2_8 = zc_8 + z2_8
z1_8 =-zc_8 + z1_8 + b4_8
*
zi(i+2,j+2,k) = z4_8 + zi(i+2,j+2,k)
zi(i+1,j+2,k) = z3_8 + zi(i+1,j+2,k)
zi(i ,j+2,k) = z2_8 + zi(i ,j+2,k)
zi(i-1,j+2,k) = z1_8 + zi(i-1,j+2,k)
*
* Adjoint of
* interpolation row 3
* -------------------
a32_8 = (x_8-x1_8)*b3_8
a33_8 = (x_8-x2_8)*a32_8
a34_8 = (x_8-x3_8)*a33_8
*
za_8 = a34_8 * cx(i,4)
zb_8 =-za_8 + a33_8
*
z1_8 = wa_8 * zb_8
z4_8 = wb_8 * za_8
z2_8 =(wc_8 * za_8 - wd_8 * zb_8) - z1_8
z3_8 =(wd_8 * zb_8 - wc_8 * za_8) - z4_8
*
zc_8 = cx(i,1) * a32_8
*
z2_8 = zc_8 + z2_8
z1_8 =-zc_8 + z1_8 + b3_8
*
zi(i+2,j+1,k) = z4_8 + zi(i+2,j+1,k)
zi(i+1,j+1,k) = z3_8 + zi(i+1,j+1,k)
zi(i ,j+1,k) = z2_8 + zi(i ,j+1,k)
zi(i-1,j+1,k) = z1_8 + zi(i-1,j+1,k)
*
* Adjoint of
* interpolation row 2
* -------------------
a22_8 = (x_8-x1_8)*b2_8
a23_8 = (x_8-x2_8)*a22_8
a24_8 = (x_8-x3_8)*a23_8
*
za_8 = a24_8 * cx(i,4)
zb_8 =-za_8 + a23_8
*
z1_8 = wa_8 * zb_8
z4_8 = wb_8 * za_8
z2_8 =(wc_8 * za_8 - wd_8 * zb_8) - z1_8
z3_8 =(wd_8 * zb_8 - wc_8 * za_8) - z4_8
*
zc_8 = cx(i,1) * a22_8
*
z2_8 = zc_8 + z2_8
z1_8 =-zc_8 + z1_8 + b2_8
*
zi(i+2,j,k) = z4_8 + zi(i+2,j,k)
zi(i+1,j,k) = z3_8 + zi(i+1,j,k)
zi(i ,j,k) = z2_8 + zi(i ,j,k)
zi(i-1,j,k) = z1_8 + zi(i-1,j,k)
*
* Adjoint of
* interpolation row 1
* -------------------
a12_8 = (x_8-x1_8)*b1_8
a13_8 = (x_8-x2_8)*a12_8
a14_8 = (x_8-x3_8)*a13_8
*
za_8 = a14_8 * cx(i,4)
zb_8 =-za_8 + a13_8
*
z1_8 = wa_8 * zb_8
z4_8 = wb_8 * za_8
z2_8 =(wc_8 * za_8 - wd_8 * zb_8) - z1_8
z3_8 =(wd_8 * zb_8 - wc_8 * za_8) - z4_8
*
zc_8 = cx(i,1) * a12_8
*
z2_8 = zc_8 + z2_8
z1_8 =-zc_8 + z1_8 + b1_8
*
zi(i+2,j-1,k) = z4_8 + zi(i+2,j-1,k)
zi(i+1,j-1,k) = z3_8 + zi(i+1,j-1,k)
zi(i ,j-1,k) = z2_8 + zi(i ,j-1,k)
zi(i-1,j-1,k) = z1_8 + zi(i-1,j-1,k)
*
end do
end do
!$omp enddo
*
!$omp end parallel
*
return
end