!-------------------------------------- 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_grid - compute the grid of the model
#include "model_macros_f.h"
*
subroutine e_grid 2,6
implicit none
*
*author unknown
*
*revision
* v2_30 - Dugas B. - use real*8 rotation matrices and
* v2_30 cartesian coordinates
* v3_00 - Desgagne & Lee - Lam configuration
* v3_11 - Tanguay M. - Introduce Grd_gauss_L
* v3_30 - Desgagne M. - Check that LAM grid does not extend to
* global coverage and eliminated Grd_roule
*
*implicits
#include "e_grids.cdk"
#include "e_geomg.cdk"
#include "dcst.cdk"
#include "hgc.cdk"
#include "grd.cdk"
*
integer stretch_axis2, ezgdef_fmem
external stretch_axis2, ezgdef_fmem
*
logical global_extend
integer i,j,nleft,nbelo,nimax,njmax,ier,ni,nila,ng
real r1,s1,x0,y0,xl,yl
real*8 y_8(Grd_nj+2), x2_8(2000), y2_8(2000)
real*8, dimension (:), allocatable :: x_8
real*8 pt5,epsilon,deg2rad_8,ONE_8,CLXXX_8
parameter ( pt5 = 0.5d0, epsilon = 1.0d-5)
parameter ( ONE_8 = 1.0 , CLXXX_8 = 180.0 )
**
*----------------------------------------------------------------------
*
write(6,1001)
*
global_extend = (abs(1.0d0-abs(Grd_xl-Grd_x0)/360.d0).lt.epsilon)
$ .or. (abs(1.0d0-abs(Grd_yl-Grd_y0)/180.d0).lt.epsilon)
*
if (LAM .and. global_extend) then
write (6,2005)
stop
endif
*
allocate (xfi(nifi),yfi(njfi),xu(niu),yv(njv))
*
ni = Grd_ni
nila = Grd_nila
if (.not.lam) then
ni=ni+1
if ( ni .eq. nila+1) nila=nila+1
endif
*
allocate (x_8(ni+2))
*
* compute x and y positions of the PHI grid
*
ier=stretch_axis2 ( x_8, Grd_dx, Grd_x0, Grd_xl, nleft, ni, nila,
$ r1, .false., .false., Grd_dxmax, nimax,
$ Grd_gauss_L, Dcst_pi_8 )
*
if (ier.ne.0) then
write(6,*)'ERROR in generating X axis!!! ABORT!!!!'
call e_arret('e_gridgef')
endif
*
if (LAM) then
ier=stretch_axis2 ( y_8, Grd_dy, Grd_y0, Grd_yl, nbelo, Grd_nj,
$ Grd_njla, s1, .false., .false., Grd_dymax,
$ njmax, Grd_gauss_L, Dcst_pi_8 )
else
ier=stretch_axis2 ( y_8, Grd_dy, Grd_y0, Grd_yl, nbelo, Grd_nj,
$ Grd_njla, s1, .true., .false., Grd_dymax,
$ njmax, Grd_gauss_L, Dcst_pi_8 )
endif
*
call readgrid (x_8,y_8,Grd_ni,Grd_nj)
*
if (ier.ne.0) then
write(6,*)'ERROR in generating Y axis!!! ABORT!!!!'
call e_arret('e_gridgef')
endif
*
* compute the staggered positions for U and V grids
*
do i=1,ni-2
xu(i) = pt5 * ( x_8(i) + x_8(i+1) )
enddo
if (.not.LAM) then
xu(ni-1) = pt5 * ( x_8(ni-1) + x_8(1) + 360. )
xu(ni ) = pt5 * ( x_8 (1) + x_8(2) ) + 360.
else
xu(ni-1) = pt5 * ( x_8(ni-1) + x_8(ni))
endif
do i=1,Grd_nj-1
yv(i) = pt5 * ( y_8(i) + y_8(i+1) )
enddo
*
* convert to real*4
*
do i=1,ni
xfi(i)=x_8(i)
enddo
do j=1,Grd_nj
yfi(j)=y_8(j)
enddo
*
deallocate (x_8)
*
* adjust grid coverage parameters
*
x0 = xfi(1)
y0 = yfi(1)
xl = xfi(ni)
yl = yfi(Grd_nj)
*
write(6,1020) ni,x0,xl,Grd_nj,y0,yl,
$ Grd_xlon1,Grd_xlat1
write(6,1025) nila,Grd_dx,1+nleft,1+nleft+nila-1,
$ Grd_njla,Grd_dy,1+nbelo,1+nbelo+Grd_njla-1
i = ni-nila-nleft
j = Grd_nj-Grd_njla-nbelo
write(6,1030) nleft,i,r1,xfi(2)-xfi(1),
$ nbelo,j,s1,yfi(2)-yfi(1)
*
if ( nimax .gt. 0 ) write(6,1035) Grd_dxmax, nimax, 'X','X'
if ( njmax .gt. 0 ) write(6,1035) Grd_dymax, njmax, 'Y','Y'
write(6,1031)
*
dstf_gid = ezgdef_fmem (ni , Grd_nj , 'Z', 'E', Hgc_ig1ro,
$ Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro, xfi , yfi )
dstu_gid = ezgdef_fmem (niu, Grd_nj , 'Z', 'E', Hgc_ig1ro,
$ Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro, xu , yfi )
dstv_gid = ezgdef_fmem (ni , njv , 'Z', 'E', Hgc_ig1ro,
$ Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro, xfi , yv )
*
allocate (xdx(nifi),xdy(njfi),xdxu(nifi),xdyv(njfi))
allocate (xdcy(pnj),xdcyv(pnjv),xdhx(pni),xdhy(pnj),
$ xdhxu(0:pniu), xdhyv(0:pnjv) )
*
deg2rad_8 = acos( -ONE_8 )/CLXXX_8
*
if (LAM) then
do i = 1, nifi
xdx(i) = xfi(i) * deg2rad_8
enddo
do i = 1,niu
xdxu (i) = xu (i) * deg2rad_8
enddo
else
do i = 1,nifi-1
xdx(i) = xfi(i) * deg2rad_8
xdxu (i) = xu (i) * deg2rad_8
enddo
endif
do j = 1,njfi
xdy(j) = yfi(j) * deg2rad_8
enddo
do j = 1,njv
xdyv (j) = yv (j) * deg2rad_8
enddo
*
do j=1,pnj
xdcy(j) = cos( xdy (j) )
enddo
do j=1,pnjv
xdcyv(j) = cos( xdyv(j) )
enddo
do i=1,pni-1
xdhx(i) = xdx(i+1) - xdx(i)
enddo
do j=1,pnj-1
xdhy(j) = xdy(j+1) - xdy(j)
enddo
do i=1,pniu-1
xdhxu(i) = xdxu(i+1) - xdxu(i)
enddo
do j=1,pnjv-1
xdhyv(j) = xdyv(j+1) - xdyv(j)
enddo
xdhy(pnj) = xdhy(pnj-1)
*
if (lam) then
xdhx (pni ) = xdhx (pni- 1)
xdhxu( 0 ) = xdhxu( 1)
xdhxu(pniu) = xdhxu(pniu-1)
xdhyv( 0) = xdhyv(1 )
xdhyv(pnjv) = xdhyv(pnjv-1)
else
xdhx (pni ) = xdx (1) + 2.0 * Dcst_pi_8 - xdx (pni )
xdhxu( 0 ) = xdxu (1) + 2.0 * Dcst_pi_8 - xdxu(pniu)
xdhxu(pniu) = xdhxu(0)
xdhyv(0 ) = xdyv (1) + ( Dcst_pi_8 / 2.0 )
xdhyv(pnjv) = ( Dcst_pi_8 / 2.0 ) - xdyv(pnjv)
endif
*
*----------------------------------------------------------------------
*
2005 format (/' LAM grid extends to global coverage on at least ',
$ /' one axis ---- ABORT -----'/)
1001 format (/1x,'COMPUTE MODEL GRID (S/R E_GRIDGEF)',
$ /1x,34('='))
1020 FORMAT (/1X,'FINAL HORIZONTAL GRID CONFIGURATION:'
$ /1X,' NI=',I4,' FROM Grd_x0=',F9.3,' TO Grd_xl=',F9.3,' DEGREES'
$ /1X,' NJ=',I4,' FROM Grd_y0=',F9.3,' TO Grd_yl=',F9.3,' DEGREES'
$ /1X,' CENTRAL POINT OF THE GRID Grd_xlon1,Grd_xlat1=',
$ 2F9.3,' DEGREES'/1x,74('='))
1025 FORMAT(/1X,'THE CONSTANT RESOLUTION AREA HAS:',
$ /1X,' NILA=',I4,' OF GRID-LENGTH=',F9.4,' DEGREES',
$ 1x,'(',i4,',',i4,' )',
$ /1X,' NJLA=',I4,' OF GRID-LENGTH=',F9.4,' DEGREES',
$ 1x,'(',i4,',',i4,' )',
$ /1x,56('='))
1030 FORMAT(/1X,'THE VARIABLE RESOLUTION AREA HAS:'
$ /1X,i3,' POINTS TO THE WEST AND ',i3,' POINTS TO THE EAST'
$ /2x,'WITH STRETCHING FACTOR=',F8.4,
$ ' AND MINIMUM RESOLUTION=',F8.4,
$ /1X,i3,' POINTS ON THE SOUTH AND ',i3,' POINTS ON THE NORTH'
$ /2x,'WITH STRETCHING FACTOR=',F8.4,
$ ' AND MINIMUM RESOLUTION=',F8.4)
1031 FORMAT(1x,64('='))
1035 FORMAT(2x,'RESOLUTION IS LIMITED TO ',F9.4,1x,
$ 'DEGREES OVER LAST',I4,' DELTA-',a1,' AT ',
$ 'EACH ENDS OF THE ',a1,' AXIS.')
*
*----------------------------------------------------------------------
*
return
end