!-------------------------------------- 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/p - uv_acg2g_ad - ADJ of uv_acg2g
*
#include "model_macros_f.h"
*
subroutine uv_acg2g_ad (F_dst,F_src,F_gridi,F_grido,DIST_DIM, 2,1
$ Nk,F_i0,F_in,F_j0,F_jn)
*
implicit none
*
integer DIST_DIM,Nk,F_i0,F_in,F_j0,F_jn
integer F_gridi, F_grido
real F_dst(DIST_SHAPE,Nk), F_src(DIST_SHAPE,Nk)
*
*
*author
* S. Laroche
*
*
*revision
* v3_00 - Laroche S. - initial MPI version
* v3_02 - Tanguay M. - introduce nie,nje as in uv_acg2g
* v3_03 - Tanguay M. - Adjoint Lam configuration
* v3_11 - Tanguay M. - Allow .not.cubic interpolation
* v3_20 - Tanguay M. - replace grido by gridi in exchange halo
* v3_21 - Tanguay M. - Revision Openmp
* v3_31 - Tanguay M. - replace G_nk and l_nk by Nk
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_dst O - field on target grid
* F_src O - field on source grid
* F_gridi I - type of input grid : 0 - scalar-grid
* 1 - u-grid
* 2 - v-grid
* F_grido I - type of output grid: see F_gridi
* F_i0 O - starting point of calculation on W-E axis
* F_in O - ending point of calculation on W-E axis
* F_j0 O - starting point of calculation on N-S axis
* F_jn O - ending point of calculation on N-S axis
*
*implicits
#include "glb_ld.cdk"
#include "schm.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
*
*modules
**
logical cubic
integer i,j,k,nie,nje
*
real*8, parameter :: ZERO_8 = 0.0
*
*-----------------------------------------------------------------
*
cubic = Schm_adcub_L
*
* check input grid
*
if ( F_gridi .eq. 0 .and. F_grido .eq. 1) then
F_i0 = 1
F_in = l_niu
F_j0 = 1
F_jn = l_nj
if ((G_lam).and.(l_west)) F_i0 = 2
if ((G_lam).and.(l_east)) F_in = l_niu-1
*
!$omp do
do k = 1,Nk
do j = F_j0, F_jn
do i = F_in, F_i0, -1
F_src(i-1,j,k) = F_src(i-1,j,k) + F_dst(i,j,k)*inuvl_wxxu3_8(i,1)
F_src(i ,j,k) = F_src(i ,j,k) + F_dst(i,j,k)*inuvl_wxxu3_8(i,2)
F_src(i+1,j,k) = F_src(i+1,j,k) + F_dst(i,j,k)*inuvl_wxxu3_8(i,3)
F_src(i+2,j,k) = F_src(i+2,j,k) + F_dst(i,j,k)*inuvl_wxxu3_8(i,4)
F_dst(i,j,k) = ZERO_8
end do
end do
end do
!$omp end do
endif
if ( F_gridi .eq. 0 .and. F_grido .eq. 2) then
F_i0 = 1
F_in = l_ni
F_j0 = 1
F_jn = l_njv
if (l_south) F_j0 = 2
if (l_north) F_jn = l_njv - 1
!$omp do
do k = 1,Nk
*
if (.not.G_lam) then
if (l_north) then
do i = F_i0, F_in
F_src(i,l_njv-1,k) = F_src(i,l_njv-1,k) + F_dst(i,l_njv,k)*inuvl_wyyv3_8(l_njv,1)
F_src(i,l_njv ,k) = F_src(i,l_njv ,k) + F_dst(i,l_njv,k)*inuvl_wyyv3_8(l_njv,2)
F_src(i,l_njv+1,k) = F_src(i,l_njv+1,k) + F_dst(i,l_njv,k)*inuvl_wyyv3_8(l_njv,3)
F_dst(i,l_njv,k) = ZERO_8
end do
endif
if (l_south) then
do i = F_i0, F_in
F_src(i,1,k) = F_src(i,1,k) + F_dst(i,1,k)*inuvl_wyyv3_8(1,2)
F_src(i,2,k) = F_src(i,2,k) + F_dst(i,1,k)*inuvl_wyyv3_8(1,3)
F_src(i,3,k) = F_src(i,3,k) + F_dst(i,1,k)*inuvl_wyyv3_8(1,4)
F_dst(i,1,k) = ZERO_8
end do
endif
endif
do j = F_jn, F_j0, -1
do i = F_i0, F_in
F_src(i,j-1,k) = F_src(i,j-1,k) + F_dst(i,j,k)*inuvl_wyyv3_8(j,1)
F_src(i,j ,k) = F_src(i,j ,k) + F_dst(i,j,k)*inuvl_wyyv3_8(j,2)
F_src(i,j+1,k) = F_src(i,j+1,k) + F_dst(i,j,k)*inuvl_wyyv3_8(j,3)
F_src(i,j+2,k) = F_src(i,j+2,k) + F_dst(i,j,k)*inuvl_wyyv3_8(j,4)
F_dst(i,j,k) = ZERO_8
end do
end do
*
enddo
!$omp enddo
endif
*
if ( F_gridi .eq. 1 .and. F_grido .eq. 0) then
*
F_i0 = 1
F_in = l_niu
F_j0 = 1
F_jn = l_nj
if ((G_lam).and.(l_west)) then
F_i0 = 2
if (cubic) F_i0 = 3
endif
if ((G_lam).and.(l_east).and.(cubic)) F_in = l_niu-1
*
!$omp do
do k = 1,Nk
if ( .not. cubic ) then ! Linear interpolation
*
do j = F_j0, F_jn
do i = F_in, F_i0, -1
*
F_src(i-1,j,k) = (1.0 - intuv_c0xux_8(i-1)) * F_dst(i,j,k) + F_src(i-1,j,k)
F_src(i ,j,k) = intuv_c0xux_8(i-1) * F_dst(i,j,k) + F_src(i ,j,k)
F_dst(i, j,k) = ZERO_8
*
end do
end do
*
else ! Lagrange cubic interpolation
*
do j = F_j0, F_jn
do i = F_in, F_i0,-1
*
F_src(i-2,j,k) = inuvl_wxux3_8(i,1) * F_dst(i,j,k) + F_src(i-2,j,k)
F_src(i-1,j,k) = inuvl_wxux3_8(i,2) * F_dst(i,j,k) + F_src(i-1,j,k)
F_src(i ,j,k) = inuvl_wxux3_8(i,3) * F_dst(i,j,k) + F_src(i ,j,k)
F_src(i+1,j,k) = inuvl_wxux3_8(i,4) * F_dst(i,j,k) + F_src(i+1,j,k)
F_dst(i, j,k) = ZERO_8
*
end do
end do
*
endif
end do
!$omp end do
*
endif
*
if ( F_gridi .eq. 2 .and. F_grido .eq. 0) then
F_i0 = 1
F_in = l_ni
F_j0 = 1
F_jn = l_njv
if (cubic) then
if (l_south) F_j0 = 3
if (l_north) F_jn = l_njv - 1
else
if (l_south) F_j0 = 2
endif
*
!$omp do
do k = 1,Nk
if ( .not. cubic ) then ! Linear interpolation
*
if (.not.G_lam) then
if (l_north) then
do i = F_i0, F_in
F_src(i,F_jn, k) = (1.0-intuv_c0yvy_8(F_jn))* F_dst(i,F_jn+1,k) + F_src(i,F_jn, k)
F_dst(i,F_jn+1,k) = ZERO_8
end do
endif
if (l_south) then
do i = F_i0, F_in
F_src(i,1,k) = intuv_c0yvy_8(0) * F_dst(i,1,k) + F_src(i,1,k)
F_dst(i,1,k) = ZERO_8
end do
endif
endif
*
do j = F_jn, F_j0,-1
do i = F_i0, F_in
F_src(i,j-1,k) = (1.0 - intuv_c0yvy_8(j-1)) * F_dst(i,j,k) + F_src(i,j-1,k)
F_src(i,j, k) = intuv_c0yvy_8(j-1) * F_dst(i,j,k) + F_src(i,j, k)
F_dst(i,j, k) = ZERO_8
end do
end do
*
else ! Lagrange cubic interpolation
*
if (.not.G_lam) then
if (l_north) then
do i = F_i0, F_in
F_src(i,F_jn-1,k) = inuvl_wyvy3_8(F_jn+1,1) * F_dst(i,F_jn+1,k) + F_src(i,F_jn-1,k)
F_src(i,F_jn ,k) = inuvl_wyvy3_8(F_jn+1,2) * F_dst(i,F_jn+1,k) + F_src(i,F_jn ,k)
F_src(i,F_jn+1,k) = inuvl_wyvy3_8(F_jn+1,3) * F_dst(i,F_jn+1,k) + F_src(i,F_jn+1,k)
F_dst(i,F_jn+1,k) = ZERO_8
*
F_src(i,F_jn ,k) = inuvl_wyvy3_8(F_jn+2,1) * F_dst(i,F_jn+2,k) + F_src(i,F_jn ,k)
F_src(i,F_jn+1,k) = inuvl_wyvy3_8(F_jn+2,2) * F_dst(i,F_jn+2,k) + F_src(i,F_jn+1,k)
F_dst(i,F_jn+2,k) = ZERO_8
end do
endif
if (l_south) then
do i = F_i0, F_in
F_src(i,1,k) = inuvl_wyvy3_8(2,2) * F_dst(i,2,k) + F_src(i,1,k)
F_src(i,2,k) = inuvl_wyvy3_8(2,3) * F_dst(i,2,k) + F_src(i,2,k)
F_src(i,3,k) = inuvl_wyvy3_8(2,4) * F_dst(i,2,k) + F_src(i,3,k)
F_dst(i,2,k) = ZERO_8
*
F_src(i,1,k) = inuvl_wyvy3_8(1,3) * F_dst(i,1,k) + F_src(i,1,k)
F_src(i,2,k) = inuvl_wyvy3_8(1,4) * F_dst(i,1,k) + F_src(i,2,k)
F_dst(i,1,k) = ZERO_8
end do
endif
endif
*
do j = F_jn,F_j0,-1
do i = F_i0, F_in
F_src(i,j-2,k) = inuvl_wyvy3_8(j,1) * F_dst(i,j,k) + F_src(i,j-2,k)
F_src(i,j-1,k) = inuvl_wyvy3_8(j,2) * F_dst(i,j,k) + F_src(i,j-1,k)
F_src(i,j ,k) = inuvl_wyvy3_8(j,3) * F_dst(i,j,k) + F_src(i,j ,k)
F_src(i,j+1,k) = inuvl_wyvy3_8(j,4) * F_dst(i,j,k) + F_src(i,j+1,k)
F_dst(i,j, k) = ZERO_8
end do
end do
*
endif
*
enddo
!$omp enddo
*
endif
if (F_grido .eq. F_gridi) then
*
* copy grid as is
*
F_i0 = 1
F_in = l_ni
F_j0 = 1
F_jn = l_nj
*
!$omp do
do k = 1, Nk
do j = F_j0, F_jn
do i = F_i0, F_in
F_src(i,j,k) = F_dst(i,j,k) + F_src(i,j,k)
F_dst(i,j,k) = ZERO_8
end do
end do
end do
!$omp end do
else
!$omp single
nie = l_ni
nje = l_nj
if (F_gridi.eq.1) nie = l_niu
if (F_gridi.eq.2) nje = l_njv
call rpn_comm_adj_halo( F_src,LDIST_DIM,nie,nje,Nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* Zero F_src halo
* ---------------
call v4d_zerohalo ( F_src,nie,nje,LDIST_DIM, Nk)
!$omp end single
*
endif
*
*-----------------------------------------------------------------
return
end