!-------------------------------------- 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 nes3s -- Horizontal nesting on 3 faces
*
#include "model_macros_f.h"
subroutine nes3s (F_fn, F_fd, DIST_DIM, Nk, F_is, F_js, 1
$ F_ndavx, F_ndavy)
implicit none
*
integer DIST_DIM, NK, F_is, F_js, F_ndavx, F_ndavy
real F_fn(DIST_SHAPE,Nk), F_fd(DIST_SHAPE,Nk)
*
*author
* Andre Robert
*
*revision
* v3_00 - Desgagne - initial version
* v3_20 - Desgagne M. - correction of starting/ending point for blend
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_fn O field to be blended
* F_fd I blending field
* F_is I staggering parameter along x
* F_js I staggering parameter along y
* F_ndavx I thichness of sponge layer along x
* F_ndavy I thichness of sponge layer along y
*----------------------------------------------------------------
*
*implicit
#include "glb_ld.cdk"
#include "hblen.cdk"
*
**
integer i,j,k,nit,njt,il,ih,jl,jh,un
real*8 zero,one,pt5,lx,ly,p,pis2
parameter (zero=0.d0, one=1.d0, pt5=0.5d0)
*----------------------------------------------------------------------
*100
* * ndavx et ndavy: nombre de points de grille dans la bande de
* * pilotage (eponge) excluant les frontieres.
*
nit = l_ni-F_is-pil_e
njt = l_nj-F_js-pil_n
*
il = 1 + F_ndavx + pil_w -1
ih = nit - F_ndavx + 1
jl = 1 + F_ndavy + pil_s -1
jh = njt - F_ndavy + 1
*
lx = dble(F_ndavx) - pt5
ly = dble(F_ndavy) - pt5
*
pis2 = acos(zero)
un = 1
*
* In off-line mode weight function = 0.0
*
if (Hblen_wfct_S .eq. "CONST") then
pis2=0.d0
un=0
endif
*
*
if (l_north.and.l_south) then
if (l_west) then
do k=1,Nk
*west
do i=1+pil_w,il-un
do j=jl,jh
p = (cos(pis2*(i-pil_w-1)/lx))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south
do j=1+pil_s,jl-un
do i=il,l_ni
p = (cos(pis2*(j-pil_s-1)/ly))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north
do j=jh+1,njt
do i=il,l_ni
p = (cos(pis2*(njt-j)/ly))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south-west
do i=1+pil_w,il-un
do j=1+pil_s,jl-un
p = (cos(pis2*(one-min(one,
$ sqrt(((lx-i+1+pil_w)/lx)**2+((ly-j+1+pil_s)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north-west
do i=1+pil_w,il-un
do j=jh+1,njt
p = (cos(pis2*(one-min(one,
$ sqrt(((lx-i+1+pil_w)/lx)**2+((j-njt+ly)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
end do
endif
if (l_east) then
do k=1,Nk
*east
do i=ih+1,nit
do j=jl,jh
p = (cos(pis2*(nit-i)/lx))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south
do j=1+pil_s,jl-1
do i=1,ih
p = (cos(pis2*(j-pil_s-1)/ly))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north
do j=jh+1,njt
do i=1,ih
p = (cos(pis2*(njt-j)/ly))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south-east
do i=ih+1,nit
do j=1+pil_s,jl-1
p = (cos(pis2*(one-min(one,
$ sqrt(((i-nit+lx)/lx)**2+((ly-j+1+pil_s)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north-east
do i=ih+1,nit
do j=jh+1,njt
p = (cos(pis2*(one-min(one,
$ sqrt(((i-nit+lx)/lx)**2+((j-njt+ly)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
end do
endif
else
if (l_north) then
do k=1,Nk
*west
do i=1+pil_w,il-1
do j=1,jh
p = (cos(pis2*(i-pil_w-1)/lx))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*east
do i=ih+1,nit
do j=1,jh
p = (cos(pis2*(nit-i)/lx))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north
do j=jh+1,njt
do i=il,ih
p = (cos(pis2*(njt-j)/ly))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north-west
do i=1+pil_w,il-1
do j=jh+1,njt
p = (cos(pis2*(one-min(one,
$ sqrt(((lx-i+1+pil_w)/lx)**2+((j-njt+ly)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*north-east
do i=ih+1,nit
do j=jh+1,njt
p = (cos(pis2*(one-min(one,
$ sqrt(((i-nit+lx)/lx)**2+((j-njt+ly)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
end do
endif
if (l_south) then
do k=1,Nk
*west
do i=1+pil_w,il-1
do j=jl,l_nj
p = (cos(pis2*(i-pil_w-1)/lx))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*east
do i=ih+1,nit
do j=jl,l_nj
p = (cos(pis2*(nit-i)/lx))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south
do j=1+pil_s,jl-1
do i=il,ih
p = (cos(pis2*(j-pil_s-1)/ly))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south-west
do i=1+pil_w,il-1
do j=1+pil_s,jl-1
p = (cos(pis2*(one-min(one,
$ sqrt(((lx-i+1+pil_w)/lx)**2+((ly-j+1+pil_s)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
*south-east
do i=ih+1,nit
do j=1+pil_s,jl-1
p = (cos(pis2*(one-min(one,
$ sqrt(((i-nit+lx)/lx)**2+((ly-j+1+pil_s)/ly)**2)))))**2
F_fn(i,j,k)= (one-p)*F_fn(i,j,k)+p*F_fd(i,j,k)
end do
end do
end do
endif
endif
*
*----------------------------------------------------------------------
return
end