!-------------------------------------- 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 adw_cliptraj_ad - ADJ of adw_cliptraj_tl
*
#include "model_macros_f.h"
*
subroutine adw_cliptraj_ad ( F_x_in, F_y_in, F_xm_in, F_ym_in, i0, in, j0, jn, mesg ) 6,1
*
implicit none
*
character*(*) mesg
integer i0, in, j0, jn
real F_x_in ( * ), F_y_in ( * )
real F_xm_in( * ), F_ym_in( * )
*
*author M.Tanguay
*
*revision
* v3_31 - Tanguay M. - Initial version
*
*object
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* F_x_in | upstream positions (x-component | i/o |
* F_y_in | upstream positions (y-component | i/o |
* i0,in | x direction scope of operator | i |
* j0,jn | y direction scope of operator | i |
*______________|_________________________________________________|_____|
*
*
*implicits
#include "ptopo.cdk"
#include "glb_ld.cdk"
#include "adw.cdk"
#include "lun.cdk"
#include "step.cdk"
*
integer n, nij, i,j,k, ipos, jpos, cnt, kt, sum_cnt, sum_kt, err
real*8 eps
real minposx,maxposx,minposy,maxposy,
$ posxmin,posxmax,posymin,posymax
common /clip_sum/ cnt, kt, sum_cnt, sum_kt
*
* __________________________________________________________________
*
if (.not.Step_cliptraj_L) call gem_stop('ADW_CLIPTRAJ_AD not DONE',-1)
*
nij = l_ni*l_nj
*
eps=1.0d-5
minposx= Adw_xx_8(2) + eps
if (l_west) minposx= Adw_xx_8(Adw_halox+5) + eps
maxposx= Adw_xx_8(Adw_nit-1 ) - eps
if (l_east) maxposx= Adw_xx_8(Adw_nit-Adw_halox-4) - eps
minposy= Adw_yy_8(2) + eps
if (l_south) minposy= Adw_yy_8(Adw_haloy+5) + eps
maxposy= Adw_yy_8(Adw_njt-1) - eps
if (l_north) maxposy= Adw_yy_8(Adw_njt-Adw_haloy-4) - eps
cnt=0
kt =0
if (Step_cliptraj_L) then ! Clipping to Step_maxcfl
do k=1,l_nk
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
ipos= i+Adw_halox
jpos= j+Adw_haloy
posxmin = Adw_xx_8(ipos-Step_maxcfl) + eps
posxmax = Adw_xx_8(ipos+Step_maxcfl) - eps
posymin = Adw_yy_8(jpos-Step_maxcfl) + eps
posymax = Adw_yy_8(jpos+Step_maxcfl) - eps
posxmin = max(posxmin, minposx)
posxmax = min(posxmax, maxposx)
posymin = max(posymin, minposy)
posymax = min(posymax, maxposy)
if ( (F_xm_in(n).lt.posxmin).or.(F_xm_in(n).gt.posxmax).or.
$ (F_ym_in(n).lt.posymin).or.(F_ym_in(n).gt.posymax) ) then
cnt=cnt+1
kt = kt+k
if (F_xm_in(n).lt.posxmin) F_x_in(n) = 0.
if (F_xm_in(n).gt.posxmax) F_x_in(n) = 0.
if (F_ym_in(n).lt.posymin) F_y_in(n) = 0.
if (F_ym_in(n).gt.posymax) F_y_in(n) = 0.
endif
c F_xm_in(n) = min(max(F_xm_in(n),posxmin),posxmax)
c F_ym_in(n) = min(max(F_ym_in(n),posymin),posymax)
enddo
enddo
enddo
else ! Clipping to processor boundary
do k=1,l_nk
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
if ( (F_x_in(n).lt.minposx).or.(F_x_in(n).gt.maxposx).or.
$ (F_y_in(n).lt.minposy).or.(F_y_in(n).gt.maxposy) ) then
cnt=cnt+1
kt = kt+k
endif
F_x_in(n) = min(max(F_x_in(n),minposx),maxposx)
F_y_in(n) = min(max(F_y_in(n),minposy),maxposy)
enddo
enddo
enddo
endif
*
call rpn_comm_Allreduce(cnt,sum_cnt,2,"MPI_INTEGER",
$ "MPI_SUM","grid",err)
*
nij = G_nk*(G_niu-2*pil_e+2)*(G_njv-2*pil_s+2)
if ( (trim(mesg).ne."") .and. (Lun_out.gt.0) .and. (sum_cnt.gt.0))
$ write(Lun_out,1001) sum_cnt,real(sum_cnt)/real(nij)*100.,
$ sum_kt/sum_cnt,mesg
*
1001 format (' ADW trajtrunc_AD: npts=',i5,', %='f6.2,', avg_k=',i3,2x,a)
* __________________________________________________________________
*
return
end