!-------------------------------------- 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 e_setdgf - sets comdeck for horizontal digital filtering
*
subroutine e_setdgf (frchmp,fnis,fnjs, fni,fnj, F_HX,F_HY,map_fact) 3,2
implicit none
*
integer fni, fnj, fnis, fnjs
real*8 F_HX(*), F_HY(*), map_fact(*)
real frwrk(fnis,fnjs), frchmp(fnis,fnjs)
*
*author andre methot - cmc - mai 95
*
*revision
* v3_30 - Dugas B. - Rename nis,njs arguments to fnis,fnjs to remove
* conflicts with skip-mode variables in e_grid_i
*
*object
*
* This subroutine initializes the digital filter coefficients for
* horizontal digital filtering. This horizontal digital filter was
* designed in order to eliminate short waves resolved along one grid
* axis but unresolved along the other horizontal axis.
*
* For each grid point, the X and Y mesh lengths are compared.
* If the mesh lengths ratio is larger than "meshlenR" then a set of
* coefficient will be prepared to filter waves shorter than a critical
* length (crit_len) along the axis having the higher resolution.
*
*arguments
*
*______________________________________________________________________
* | |
* NAME | DESCRIPTION |
*--------------------|-------------------------------------------------|
* factor | factor controlling critical wave length |
* | |
* mapscale | switch: if true--> map scale is considered |
* | |
* fni | working dimension along x axis |
* fnj | working dimension along y axis |
* | |
* HX | grid point spacing along x axis |
* HY | grid point spacing along y axis |
* map_fact | map scale factor |
* _____________________________________________________________________
*
*notes
*
*implicits
#include "e_topo.cdk"
#include "e_grids.cdk"
#include "e_dgf.cdk"
*
*modules
*
**
integer i, j, n, im, ip
real l,crit_len,hy,hx,fact,meshlenR,cobuf(cndgfmx),
$ wrk(fnis,fnjs),factor
integer, dimension (:,: ), allocatable :: ptx, pty
real*8 , dimension (:,:,:), allocatable :: coeff,dgf
*
* ---------------------------------------------------------------
*
factor = 2.0
meshlenR = 3.0
*
write(6,1001)
*
* x dimension is fni+1 instead of fni because of output
* requirements in case of debugging.
*
allocate (ptx(fni+1,fnj),pty(fni+1,fnj),
$ coeff(fni+1,fnj,cndgfmx),dgf(fni+1,fnj,3))
*
*C 2. Initialize fields
* ---------------------
fact=1.0
*
do j=1,fnj
do i=1,fni+1
ptx(i,j) = 0
pty(i,j) = 0
coeff(i,j,1) = 1.
do n=2,cndgfmx
coeff(i,j,n) = 0.
enddo
enddo
enddo
*
*C 3. compute coefficients
* --------------------
do j=1,fnj
if ( Topo_dgfms_L ) fact=map_fact(j)
hy = F_HY(j)
if ( .not.LAM .and. j .eq. fnj ) hy = F_HY(fnj-1)
do i=1,fni
hx = F_HX(i)*fact
*
* check for higher resolution along x axis
*
if ( (hy) .gt. ( meshlenR*hx ) ) then
crit_len=factor*hy
l = hx
ptx(i,j) = nint( 2.*crit_len/l )
ptx(i,j) = min0( cndgfmx-1, ptx(i,j) )
if (LAM) then
ptx(i,j) = min0( fni-i, ptx(i,j))
ptx(i,j) = min0( i-1, ptx(i,j))
endif
call e_coefdgf( ptx(i,j), l, crit_len, cobuf)
do n=1, ptx(i,j)+1
coeff(i,j,n)=cobuf(n)
enddo
*
* check for higher resolution along y axis
*
else if ( (hx) .gt. ( meshlenR*hy ) ) then
crit_len=factor*hx
l = hy
pty(i,j) = nint( 2.*crit_len/l )
pty(i,j) = min0( cndgfmx-1, pty(i,j) )
pty(i,j) = min0( fnj-j, pty(i,j))
pty(i,j) = min0( j-1, pty(i,j))
call e_coefdgf( pty(i,j), l, crit_len, cobuf)
do n=1, pty(i,j)+1
coeff(i,j,n)=cobuf(n)
enddo
*
endif
*
enddo
enddo
*
do j=1,fnj
do i=1,fni
wrk(i,j)= coeff(i,j,1) * frchmp(i,j)
do n=1, ptx(i,j)
im=i-n
ip=i+n
if ( im .lt. 1 ) im = im + fni
if ( ip .gt. fni ) ip = ip - fni
wrk(i,j) = wrk(i,j) + coeff(i,j,n+1) *
% (frchmp( im,j) + frchmp( ip,j))
end do
*
do n=1, pty(i,j)
im=j-n
ip=j+n
wrk(i,j) = wrk(i,j) + coeff(i,j,n+1) *
% (frchmp(i,im) + frchmp(i,ip))
enddo
*
enddo
enddo
*
do j=1,fnj
do i=1,fni
frchmp(i,j)=wrk(i,j)
enddo
enddo
*
deallocate (ptx,pty,coeff,dgf)
*
1001 format(
%' INITIALIZE HORIZONTAL DIGITAL FILTER COMDECK (S/R E_SETDGF)'/
%' ===========================================================')
*
* ---------------------------------------------------------------
*
return
end