copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r nesmt_loc -- Horizontal nesting of topography
*
subroutine nesmt_loc (fn,fd,lminx,lmaxx,lminy,lmaxy,lnk, 1,1
$ mnmtx,mnmty,mnmx,mnmy)
implicit none
*
integer lminx,lmaxx,lminy,lmaxy,lnk,mnmtx,mnmty,mnmx,mnmy
real fn(lminx:lmaxx,lminy:lmaxy,lnk),
$ fd(lminx:lmaxx,lminy:lmaxy,lnk)
*
*IMPLICIT
#include "consdyn_8.cdk"
#include "partopo.cdk"
#include "lcldim.cdk"
#include "nestpnt.cdk"
**
integer i,j,k,id,iff,jd,jf,nit,njt,i0,in,j0,jn,err
real*8 lx,ly,arg,p,pis2
*----------------------------------------------------------------------
*
if ((mnmx.eq.0).and.(mnmy.eq.0)) return
*
err = 0
if ((ldni.le.9+mnmtx+mnmx).or.(ldnj.le.9+mnmty+mnmy)) err = -1
if (err.lt.0) print*, ldni,9+mnmtx+mnmx,ldnj,9+mnmty+mnmy,myproc
call mc2stop
(err)
*
if (myproc.eq.0) write (6,1001)
pis2 = dble(pi_8) / 2.
*
id = 1 + mnmtx
jd = 1 + mnmty
iff = gni - mnmtx - gc_ld(1,myproc) + 1
jf = gnj - mnmty - gc_ld(3,myproc) + 1
*
lx = dble(mnmx) - 0.5d0
ly = dble(mnmy) - 0.5d0
*
do k=1,lnk
*
j0 = jd+mnmy+1
jn = jf-mnmy-1
if (.not.south_L) j0 = -hy
if (.not.north_L) jn = ldnj + hy
if (west_L) then
i0 = id
in = id+mnmx
nit = -1-mnmtx
do j=j0,jn
do i=i0,in
p = cos(pis2*dble(i+nit)/lx)**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
if (east_L) then
i0 = iff-mnmx
in = iff
nit = gni-mnmtx-gc_ld(1,myproc)+1
do j=j0,jn
do i=i0,in
p = cos(pis2*dble(nit-i)/lx)**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
i0 = id+mnmx+1
in = iff-mnmx-1
if (.not.west_L) i0 = -hx
if (.not.east_L) in = ldni + hx
if (south_L) then
j0 = jd
jn = jd+mnmy
njt = -1-mnmty
do j=j0,jn
do i=i0,in
p = cos(pis2*dble(j+njt)/ly)**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
if (north_L) then
j0 = jf-mnmy
jn = jf
njt = gnj-mnmty-gc_ld(3,myproc)+1
do j=j0,jn
do i=i0,in
p = cos(pis2*dble(njt-j)/ly)**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
j0 = jd
jn = jd+mnmy
njt = mnmty+1
*
if (south_L.and.west_L) then
i0 = id
in = id+mnmx
nit = mnmtx+1
do j=j0,jn
do i=i0,in
p = (cos(pis2*(1.0d0- min(1.0d0,
$ sqrt (((lx+nit-i)/lx)**2+((ly+njt-j)/ly)**2)))))**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
if (south_L.and.east_L) then
i0 = iff-mnmx
in = iff
nit = gc_ld(1,myproc)-1-gni+mnmtx
do j=j0,jn
do i=i0,in
p = (cos(pis2*(1.0d0- min(1.0d0,
$ sqrt (((lx+nit+i)/lx)**2+((ly+njt-j)/ly)**2)))))**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
j0 = jf-mnmy
jn = jf
njt = gc_ld(3,myproc)-1-gnj+mnmty
*
if (north_L.and.west_L) then
i0 = id
in = id+mnmx
nit = mnmtx+2-gc_ld(1,myproc)
do j=j0,jn
do i=i0,in
p = (cos(pis2*(1.0d0- min(1.0d0,
$ sqrt (((lx+nit-i)/lx)**2+((ly+njt+j)/ly)**2)))))**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
if (north_L.and.east_L) then
i0 = iff-mnmx
in = iff
nit = gc_ld(1,myproc)-1-gni+mnmtx
do j=j0,jn
do i=i0,in
p = (cos(pis2*(1.0d0- min(1.0d0,
$ sqrt (((lx+nit+i)/lx)**2+((ly+njt+j)/ly)**2)))))**2
fn(i,j,k)= (1.0-p)*fn(i,j,k)+p*fd(i,j,k)
end do
end do
endif
*
if (south_L) then
do j=-hy,jd
do i=-hx,ldni+hx
fn(i,j,k)= fd(i,j,k)
end do
end do
endif
if (north_L) then
do j=jf,ldnj+hy
do i=-hx,ldni+hx
fn(i,j,k)= fd(i,j,k)
end do
end do
endif
if (west_L) then
do j=-hy,ldnj+hy
do i=-hx,id
fn(i,j,k)= fd(i,j,k)
end do
end do
endif
if (east_L) then
do j=-hy,ldnj+hy
do i=iff,ldni+hx
fn(i,j,k)= fd(i,j,k)
end do
end do
endif
end do
*
1001 format (/' Local treatment of topography - NESMT_LOC ')
*----------------------------------------------------------------------
return
end