!-------------------------------------- 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 uv_acg2g - Arakawa-C grid to grid interpolator for wind
* like quantities
*
#include "model_macros_f.h"
*
subroutine uv_acg2g (F_dst,F_src,F_gridi,F_grido,DIST_DIM, 4
$ 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
* J. Caveen - rpn - july 1995
*
*revision
* v2_00 - Lee V. - initial MPI version (from bongril v1_03)
* v2_31 - Laroche S. - add two options to interpolate from scalar
* grid to wind grids. Note that variables pil_?
* and linear interpolation are not yet
* implemented in these options.
* v3_20 - Tanguay M. - replace grido by gridi in exchange halo
* v3_22 - Desgagne M. - Revision OpenMP
* v3_30 - Tanguay M. - Revision Openmp LAM
*
*object
* Subroutine to move a given field to a specified target grid
* bongril checks the type of the input grid and takes the necessary
* steps to move the field to the target grid.
* On output, bongrid returns the grid dimensions of the target grid
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_dst O - field on target grid
* F_src I - 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 computation on W-E axis
* F_in O - ending point of computation on W-E axis
* F_j0 O - starting point of computation on N-S axis
* F_jn O - ending point of computation 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
*-----------------------------------------------------------------
*
cubic = Schm_adcub_L
*
* check input grid
*
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 parallel do
do k = 1, Nk
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k) = F_src(i,j,k)
end do
end do
end do
!$omp end parallel do
*
else
*
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_xch_halo (F_src,LDIST_DIM,nie,nje,Nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
*
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 parallel do
do k = 1,Nk
if ( .not. cubic ) then ! Linear interpolation
*
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k)= (1.0 - intuv_c0xux_8(i-1)) * F_src(i-1,j,k)
$ + intuv_c0xux_8(i-1) * F_src(i ,j,k)
end do
end do
*
else ! Lagrange cubic interpolation
*
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k) = inuvl_wxux3_8(i,1) * F_src(i-2,j,k)
$ + inuvl_wxux3_8(i,2) * F_src(i-1,j,k)
$ + inuvl_wxux3_8(i,3) * F_src(i ,j,k)
$ + inuvl_wxux3_8(i,4) * F_src(i+1,j,k)
end do
end do
*
endif
end do
!$omp end parallel 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 parallel do
do k = 1,Nk
if ( .not. cubic ) then ! Linear interpolation
*
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k)= (1.0 - intuv_c0yvy_8(j-1)) * F_src(i,j-1,k) +
$ intuv_c0yvy_8(j-1) * F_src(i,j,k)
end do
end do
*
if (.not.G_lam) then
if (l_south) then
do i = F_i0, F_in
F_dst(i,1,k) = intuv_c0yvy_8(0) * F_src(i,1,k)
end do
endif
if (l_north) then
do i = F_i0, F_in
F_dst(i,F_jn+1,k)=
$ (1.0-intuv_c0yvy_8(F_jn))*F_src(i,F_jn,k)
end do
endif
endif
*
else ! Lagrange cubic interpolation
*
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k) = inuvl_wyvy3_8(j,1) * F_src(i,j-2,k)
$ + inuvl_wyvy3_8(j,2) * F_src(i,j-1,k)
$ + inuvl_wyvy3_8(j,3) * F_src(i,j ,k)
$ + inuvl_wyvy3_8(j,4) * F_src(i,j+1,k)
end do
end do
*
if (.not.G_lam) then
if (l_south) then
do i = F_i0, F_in
F_dst(i,1,k) = inuvl_wyvy3_8(1,3) * F_src(i,1,k)
$ + inuvl_wyvy3_8(1,4) * F_src(i,2,k)
F_dst(i,2,k) = inuvl_wyvy3_8(2,2) * F_src(i,1,k)
$ + inuvl_wyvy3_8(2,3) * F_src(i,2,k)
$ + inuvl_wyvy3_8(2,4) * F_src(i,3,k)
end do
endif
if (l_north) then
do i = F_i0, F_in
F_dst(i,F_jn+2,k) =
$ inuvl_wyvy3_8(F_jn+2,1) * F_src(i,F_jn ,k)
$ + inuvl_wyvy3_8(F_jn+2,2) * F_src(i,F_jn+1,k)
F_dst(i,F_jn+1,k) =
$ inuvl_wyvy3_8(F_jn+1,1) * F_src(i,F_jn-1,k)
$ + inuvl_wyvy3_8(F_jn+1,2) * F_src(i,F_jn ,k)
$ + inuvl_wyvy3_8(F_jn+1,3) * F_src(i,F_jn+1,k)
end do
endif
endif
endif
enddo
!$omp end parallel do
*
if (.not.G_lam) then
F_j0 = 1
F_jn = l_nj
endif
*
endif
cstl
cstl ------------------- NEW OPTIONS--------------------------------
cstl Linear interpolation not coded yet
*
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 parallel do
do k = 1,Nk
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k) = inuvl_wxxu3_8(i,1)*F_src(i-1,j,k)
$ + inuvl_wxxu3_8(i,2)*F_src(i ,j,k)
$ + inuvl_wxxu3_8(i,3)*F_src(i+1,j,k)
$ + inuvl_wxxu3_8(i,4)*F_src(i+2,j,k)
end do
end do
end do
!$omp end parallel 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 parallel do
do k = 1,Nk
do j = F_j0, F_jn
do i = F_i0, F_in
F_dst(i,j,k) = inuvl_wyyv3_8(j,1)*F_src(i,j-1,k)
$ + inuvl_wyyv3_8(j,2)*F_src(i,j ,k)
$ + inuvl_wyyv3_8(j,3)*F_src(i,j+1,k)
$ + inuvl_wyyv3_8(j,4)*F_src(i,j+2,k)
end do
end do
*
if (.not.G_lam) then
if (l_south) then
do i = F_i0, F_in
F_dst(i,1,k) = inuvl_wyyv3_8(1,2)*F_src(i,1,k)
$ + inuvl_wyyv3_8(1,3)*F_src(i,2,k)
$ + inuvl_wyyv3_8(1,4)*F_src(i,3,k)
end do
endif
if (l_north) then
do i = F_i0, F_in
F_dst(i,l_njv,k) =
$ inuvl_wyyv3_8(l_njv,1)*F_src(i,l_njv-1,k)
$ + inuvl_wyyv3_8(l_njv,2)*F_src(i,l_njv ,k)
$ + inuvl_wyyv3_8(l_njv,3)*F_src(i,l_njv+1,k)
end do
endif
endif
enddo
!$omp end parallel do
*
if (.not.G_lam) then
F_j0 = 1
F_jn = l_njv
endif
endif
*
return
end