!-------------------------------------- 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_ac_posi - find the positional points to extract cascade
* grid given the analyse files
#include "model_macros_f.h"
*
integer function e_ac_posi (xpx,ypx,dimgx,dimgy,F_width, 1,1
$ F_bcs_hollow_L)
implicit none
*
integer dimgx,dimgy,F_width
logical F_bcs_hollow_L
real xpx(dimgx), ypx(dimgy)
*
*author
* Vivian Lee - 2006 (from MC2 ac_posi)
*revision
* v3_30 - Lee V. - initial version for GEMDM
* v3_31 - Tanguay M. - Allow same grid in analysis and in model (BCS mode)
*
#include "e_grids.cdk"
#include "e_anal.cdk"
#include "e_grdc.cdk"
#include "path.cdk"
#include <clib_interface.cdk>
#include "e_mta.cdk"
*
character*1024 rootfn
character* 512 filen
integer i,j,k,cnt,err,dum1,dum2,gidi,gifi,gjfi
integer is,nis,js,njs,jn,iw,niw,ie,jw,njw
integer idg,jdg
real x0, xl, y0, yl, dum, n1, n2, b1, b2
real*8 ONE_8, CLXXX_8
real*8 orr, deg2rad_8
parameter( ONE_8 = 1.0 )
parameter( CLXXX_8 = 180.0 )
*
*---------------------------------------------------------------------
*
e_same_size_L = .FALSE.
*
e_ac_posi = -1
deg2rad_8 = acos( -ONE_8 )/CLXXX_8
*
* Allocate the positional arrays in radian for the analysis grid
call hpalloc(paxg_8 , dimgx*2, err,1)
call hpalloc(payg_8 , dimgy*2, err,1)
do i=1,dimgx
xg_8(i) = xpx(i) * deg2rad_8
enddo
do i=1,dimgy
yg_8(i) = ypx(i) * deg2rad_8
enddo
*
idg=1
jdg=1
e_grdc_gid = 0
e_grdc_gjd = 0
e_grdc_gif = 0
e_grdc_gjf = 0
e_grdc_gjdi = 0
gidi=0
gifi=0
gjfi=0
*
* *** Positional parameters for f and q points
*
do i=1,dimgx
if (xpx(i).le.xfi(1)) e_grdc_gid=i
if (xpx(i).le.xfi(F_width+1)) gidi=i
if (xpx(i).le.xfi(nifi)) e_grdc_gif=i
if (xpx(i).le.xfi(nifi-F_width)) gifi=i
enddo
if (e_grdc_gid.ge.e_grdc_gif) e_grdc_gid = 0
*
do i=1,dimgy
if (ypx(i).le.yfi(1)) e_grdc_gjd=i
if (ypx(i).le.yfi(F_width+1)) e_grdc_gjdi=i
if (ypx(i).le.yfi(njfi)) e_grdc_gjf=i
if (ypx(i).le.yfi(njfi-F_width)) gjfi=i
enddo
if (e_grdc_gjd.ge.e_grdc_gjf) e_grdc_gjd = 0
*
if ((e_grdc_gid.gt.0).and.(e_grdc_gjd.gt.0)) then
if ( (e_grdc_gid-2.gt.0) .and. (e_grdc_gif+3.lt.dimgx) .and.
$ (e_grdc_gjd-2.gt.0) .and. (e_grdc_gjf+3.lt.dimgy) ) then
e_grdc_gid = e_grdc_gid - 2
e_grdc_gjd = e_grdc_gjd - 2
e_grdc_gif = e_grdc_gif + 3
e_grdc_gjf = e_grdc_gjf + 3
else
*
if ( (e_grdc_gid.eq.1) .and. (e_grdc_gif.eq.dimgx) .and.
$ (e_grdc_gjd.eq.1) .and. (e_grdc_gjf.eq.dimgy) ) then
*
print *,'E_AC_POSI: same_size grid as analysis'
e_same_size_L = .TRUE.
*
else
e_grdc_gid = 0
e_grdc_gjd = 0
endif
*
endif
else
e_grdc_gid = 0
e_grdc_gjd = 0
endif
if ((e_grdc_gid.eq.0).or.(e_grdc_gjd.eq.0)) return
*
999 continue
e_grdc_hbwe = -1
e_grdc_hbsn = -1
e_grdc_hbwe = max (gidi-e_grdc_gid+1,e_grdc_gif-gifi+1)
e_grdc_hbsn = max (e_grdc_gjdi-e_grdc_gjd+1,e_grdc_gjf-gjfi+1)
n1 = e_grdc_gif-e_grdc_gid+1
n2 = e_grdc_gjf-e_grdc_gjd+1
b1 = e_grdc_hbwe + 1
b2 = e_grdc_hbsn + 1
if (4.*b1*(n1-b1)/n1/n1.gt.0.95) e_grdc_hbwe = -1
if (4.*b2*(n2-b2)/n2/n2.gt.0.95) e_grdc_hbsn = -1
write (6,1003) e_grdc_gid,e_grdc_gif,e_grdc_gjd,e_grdc_gjf
if ((e_grdc_hbsn.le.0).or.(e_grdc_hbwe.le.0)) then
If (F_bcs_hollow_L) write(6,1005)
F_bcs_hollow_L = .false.
e_grdc_ni = e_grdc_gif-e_grdc_gid+1
e_grdc_nj = e_grdc_gjf-e_grdc_gjd+1
else
* Calculate indices for BCS output
call bcs_hollow(e_grdc_gid,e_grdc_gif,e_grdc_gjd,e_grdc_gjf,
$ e_grdc_gjdi,e_grdc_hbsn,e_grdc_hbwe,is,nis,j
$ s,njs,jn,iw,niw,ie,jw,njw)
e_grdc_is = is - e_grdc_gid+1 !Grdc_gid
e_grdc_nis = nis
e_grdc_js = js - e_grdc_gjd+1 !grdc_gjd
e_grdc_njs = njs
e_grdc_jn = jn - e_grdc_gjd+1 !Grdc_gjf-njs
*
e_grdc_iw = iw - e_grdc_gid+1 !Grdc_gid
e_grdc_niw = niw
e_grdc_ie = ie - e_grdc_gid+1 !Grdc_gif-niw
*
e_grdc_jw = jw - e_grdc_gjd+1 !Grdc_gjdi-2
e_grdc_njw = njw
*
e_grdc_ni = e_grdc_gif-e_grdc_gid+1
e_grdc_nj = e_grdc_gjf-e_grdc_gjd+1
write(6,1006)
print *,'is,nis,js,njs,jn,iw,niw,ie,jw,njw=',
$ e_grdc_is,e_grdc_nis,e_grdc_js,e_grdc_njs,e_grdc_jn,
$ e_grdc_iw,e_grdc_niw,e_grdc_ie,e_grdc_jw,e_grdc_njw
endif
e_ac_posi = 0
*
1003 format (' Cascade grid:gid,gif,gjd,gjf ',4i6)
1005 format (' BCS HOLLOW chosen but grid is too small: 3DF Cascade grid output only')
1006 format (' For HOLLOW BCS Cascade grid output')
*--------------------------------------------------------------------
return
end