copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r reducnw
subroutine reducnw ( fa,lminx,lmaxx,lminy,lmaxy,rf,nomvar,con, 1,1
$ ip2,stepno,kind,nkfa,ind_o,nko,unf )
implicit none
*
character* (*) nomvar
integer lminx,lmaxx,lminy,lmaxy,ip2,stepno,kind,nkfa,ind_o(*),
$ nko,unf
real fa(lminx:lmaxx,lminy:lmaxy,*),rf(*),con
*
**
#include "lcldim.cdk"
#include "sor.cdk"
#include "grd.cdk"
#include "partopo.cdk"
#include "yomdyn1.cdk"
*
integer fstecr,fstopc
external fstecr,fstopc
*
character*1 grdtyp
character*8 dumc
integer i,j,k,n,m,ier,pnip1,pnip2,pnip3,cnt,nis,njs,nrd,
$ ii,jj,im,jm,g3,g4,oi,oj,gl_i0,l_id,l_if,l_jd,l_jf,
$ gl_in,gl_j0,gl_jn,n1,n2,n3,n4,bw,be,bs,bn,hhx,hhy
logical reduc_L,no_data
real*8 sum_8
real, dimension (:,: ), allocatable :: tr1
real, dimension (:,:,:), allocatable :: tr2,xchg
*
*----------------------------------------------------------------------
*
hhx = max(g_reduc/2,hx)
hhy = max(g_reduc/2,hy)
*
allocate (xchg(1-hhx:ldni+hhx,1-hhy:ldnj+hhy,nkfa))
if (lminx.lt.1) then
do k=1,nkfa
do j=1-hy*south,ldnj+hy*north
do i=1-hx*west ,ldni+hx*east
xchg(i,j,k) = fa(i,j,k)
end do
end do
end do
else
do k=1,nkfa
do j=1,ldnj
do i=1,ldni
xchg(i,j,k) = fa(i,j,k)
end do
end do
do j=1-hhy*south,0
do i=1-hhx,ldni+hhx
xchg(i,j,k) = 0.
end do
end do
do j=ldnj+1,ldnj+hhy*north
do i=1-hhx,ldni+hhx
xchg(i,j,k) = 0.
end do
end do
do i=1-hhx*west,0
do j=1,ldnj
xchg(i,j,k) = 0.
end do
end do
do i=ldni+1,ldni+hhx*east
do j=1,ldnj
xchg(i,j,k) = 0.
end do
end do
end do
endif
*
call rpn_comm_xch_halo (xchg,1-hhx,ldni+hhx,1-hhy,ldnj+hhy,
$ ldni,ldnj,nkfa,hhx,hhy,period_x,period_y,ldni,0)
*
if ((out_nisl.le.0).or.(out_njsl.le.0)) goto 998
*
bw = 1 -hhx
be = ldni+hhx
bs = 1 -hhy
bn = ldnj+hhy
if ( west_L) bw = 1 -hx
if ( east_L) be = ldni+hx
if (south_L) bs = 1 -hy
if (north_L) bn = ldnj+hy
*
l_id = max( 1,(g_id-gc_ld(1,myproc) + 1))+gc_ld(1,myproc)-1
l_if = min(ldni,(g_if-gc_ld(1,myproc) + 1))+gc_ld(1,myproc)-1
l_jd = max( 1,(g_jd-gc_ld(3,myproc) + 1))+gc_ld(3,myproc)-1
l_jf = min(ldnj,(g_jf-gc_ld(3,myproc) + 1))+gc_ld(3,myproc)-1
*
n = (max(g_id,gc_ld(1,myproc))-g_id)/g_reduc
m = min(1,mod(max(g_id,gc_ld(1,myproc))-g_id,g_reduc))
gl_i0 = g_id+n*g_reduc+m*g_reduc
n = (l_if-gl_i0)/g_reduc
gl_in = n*g_reduc+gl_i0
*
n = (max(g_jd,gc_ld(3,myproc))-g_jd)/g_reduc
m = min(1,mod(max(g_jd,gc_ld(3,myproc))-g_jd,g_reduc))
gl_j0 = g_jd+n*g_reduc+m*g_reduc
n = (l_jf-gl_j0)/g_reduc
gl_jn = n*g_reduc+gl_j0
*
no_data = .false.
if ((gl_i0.gt.g_if).or.(gl_j0.gt.g_jf)) no_data = .true.
*
if (.not.no_data) then
*
n1 = (gl_i0-g_id)/g_reduc+1
n2 = (gl_in-g_id)/g_reduc+1
n3 = (gl_j0-g_jd)/g_reduc+1
n4 = (gl_jn-g_jd)/g_reduc+1
*
nis = n2-n1+1
njs = n4-n3+1
allocate ( tr1 (nis*njs, nko) )
*
do k=1,nko
n=0
do j=gl_j0,gl_jn,g_reduc
do i=gl_i0,gl_in,g_reduc
n = n+1
cnt=0
sum_8=0.0d0
im = i-gc_ld(1,myproc)+1
jm = j-gc_ld(3,myproc)+1
do jj=max(bs,jm-g_reduc/2),min(bn,jm+g_reduc/2)
do ii=max(bw,im-g_reduc/2),min(be,im+g_reduc/2)
cnt=cnt+1
sum_8 = sum_8 + xchg(ii,jj,ind_o(k))
end do
end do
tr1(n,k) = sum_8 / dble(cnt) * con
end do
end do
end do
*
else
*
n1 = 0
n2 = -1
n3 = 0
n4 = -1
*
endif
*
* Writing field 'nomvar' to a FST file
*
if (mybloc.ne.0) ier = fstopc('MSGLVL','SYSTEM',.false.)
*
if (blocme.eq.0) then
*
grdtyp = 'Z'
if (Grd_proj_S.eq.'X') grdtyp = 'X'
g3 = 0
g4 = 0
if (nblocx*nblocy.gt.1) then
grdtyp = '#'
g3 = (out_rdi-g_id)/g_reduc+1
g4 = (out_rdj-g_jd)/g_reduc+1
endif
pnip1 = 0
pnip2 = ip2
pnip3 = 0
if (gnip3.lt.0) pnip3 = stepno
allocate (tr2(out_nisl,out_njsl,nko))
oi = max(1,g3)
oj = max(1,g4)
*
endif
*
call blkcol2 ( tr2,out_nisl,out_njsl, tr1,n1,n2,n3,n4, oi,oj,nko )
*
if (blocme.eq.0) then
*
do k=1,nko
n = ind_o(k)
if (kind.ge.0) call convip(pnip1,rf(n),kind,+2,dumc,.false.)
ier = fstecr (tr2(1,1,k),tr2,-nbit,unf,out_dat0,int(grdt),
$ stepno,out_nisl,out_njsl,1,pnip1,pnip2,pnip3,
$ gttpvar,nomvar,gtetikt,grdtyp,
$ Grd_ig1,Grd_ig2,g3,g4,datyp,.false.)
end do
*
endif
*
if (.not.no_data) deallocate (tr1)
if (blocme.eq.0 ) deallocate (tr2)
*
if (mybloc.ne.0) ier = fstopc('MSGLVL','INFORM',.false.)
*
998 deallocate (xchg)
*----------------------------------------------------------------------
return
end