!-------------------------------------- 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 set_geom - initialize model geometry
*
#include "model_macros_f.h"
*
subroutine set_geom 1,10
*
implicit none
*
*author
* M. Desgagne - V. Lee ( after version v1_03 of setgeom )
*
*revision
* v2_00 - Desgagne/Lee - initial MPI version
* v2_20 - Lee V. - convert xgi,ygi to real*8
* v2_30 - Edouard S. - adapt for vertical hybrid coordinate
* v2_30 - A. Methot - introduction of a new stretch grid design
* v2_30 with upper limits on grid point spacing
* v2_30 - Desgagne M. - entry vertical interpolator in gemdm
* v3_00 - Desgagne & Lee - Lam configuration
* v3_01 - Desgagne M. - Introduce Geomn_latrx,Geomn_lonrx
* v3_11 - Tanguay M. - Introduce Grd_gauss_L
* v3_21 - Desgagne M. - Optimization
* v3_30 - Dugas B. - Corriger l'allocation de Geomg*
* v3_30 - Desgagne M. - Add calls to: set_cori, set_intuv
* and itf_phy_vlsp
*
*object
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "lun.cdk"
#include "dcst.cdk"
#include "schm.cdk"
#include "cstv.cdk"
#include "geomn.cdk"
#include "grd.cdk"
#include "geomg.cdk"
#include "p_geof.cdk"
#include "hgc.cdk"
#include "xst.cdk"
#include "ptopo.cdk"
*
*modules
integer stretch_axis2
external stretch_axis2
*
character*12 gem_debug
integer offi,offj,indx,err,dgid,ezgdef_fmem,gdll
integer i,j,k,nila,ierx,iery,nimax,njmax,dimx,dimy
real s1,r1,xfi(l_ni),yfi(l_nj)
real*8 xgi_8(Grd_ni+2), ygi_8(Grd_nj+2),xxgi_8
real*8 rad2deg_8,deg2rad_8
real*8 ZERO_8, HALF_8, ONE_8, TWO_8, CLXXX_8
parameter( ZERO_8 = 0.0 )
parameter( HALF_8 = 0.5 )
parameter( ONE_8 = 1.0 )
parameter( TWO_8 = 2.0 )
parameter( CLXXX_8 = 180.0 )
namelist / dyngrid /
$ Grd_left, Grd_belo, Grd_x0, Grd_xl, Grd_y0, Grd_yl
*
* ---------------------------------------------------------------
*
rad2deg_8 = CLXXX_8/Dcst_pi_8
deg2rad_8 = acos( -ONE_8 )/CLXXX_8
*
call hpalloc (paxg_8 , 3*G_ni , err, 8)
call hpalloc (payg_8 , 3*G_nj , err, 8)
call hpalloc (Geomn_longs_ , G_ni+1 , err, 1)
call hpalloc (Geomn_longu_ , G_ni+1 , err, 1)
call hpalloc (Geomn_latgs_ , G_nj , err, 1)
call hpalloc (Geomn_latgv_ , G_nj , err, 1)
call hpalloc (Geomn_latrx_, l_ni *l_nj , err, 1)
call hpalloc (Geomn_lonrx_, l_ni *l_nj , err, 1)
*
if (G_lam) then
ierx= stretch_axis2 ( xgi_8, Grd_dx, Grd_x0, Grd_xl, Grd_left,
$ Grd_ni, Grd_nila, r1, .false., Lun_debug_L, Grd_dxmax,
$ nimax, Grd_gauss_L, Dcst_pi_8 )
iery= stretch_axis2 ( ygi_8, Grd_dy, Grd_y0, Grd_yl, Grd_belo,
$ Grd_nj, Grd_njla, s1, .false., Lun_debug_L, Grd_dymax,
$ njmax, Grd_gauss_L, Dcst_pi_8 )
else
nila = Grd_nila
if (Grd_ni.eq.Grd_nila) nila = Grd_nila+1
ierx= stretch_axis2 ( xgi_8, Grd_dx, Grd_x0, Grd_xl, Grd_left,
$ Grd_ni+1, nila, r1, .false., Lun_debug_L, Grd_dxmax,
$ nimax, Grd_gauss_L, Dcst_pi_8 )
iery= stretch_axis2 ( ygi_8, Grd_dy, Grd_y0, Grd_yl, Grd_belo,
$ Grd_nj, Grd_njla, s1, .true., Lun_debug_L, Grd_dymax,
$ njmax, Grd_gauss_L, Dcst_pi_8 )
endif
*
call readgrid (xgi_8,ygi_8,G_ni,G_nj)
*
if (Lun_out.gt.0) then
write(Lun_out,1000)
write(Lun_out, nml=dyngrid)
write (Lun_out,1005) G_nk,Grd_rcoef
do k=1,G_nk
write (Lun_out,1006) k,Geomg_hyb(k),Geomg_hybm(k)
end do
endif
*
if (ierx.ne.0) then
if (Lun_out.gt.0)
$ write (Lun_out,*)'ERROR in generating XGI_8 values!'
call gem_stop('set_geom',-1)
endif
if (iery.ne.0.and.Lun_out.gt.0) then
if (Lun_out.gt.0)
$ write (Lun_out,*)'ERROR in generating YGI_8 values!'
call gem_stop('set_geom',-1)
endif
*
Grd_uniform_L = (G_ni.eq.Grd_nila).and.(G_nj.eq.Grd_njla).and..not.Grd_gauss_L
*
do i=1,G_ni
G_xg_8(i) = xgi_8(i)*deg2rad_8
end do
do j=1,G_nj
G_yg_8(j) = ygi_8(j)*deg2rad_8
enddo
*
do i=-G_ni+1,0
G_xg_8(i) = G_xg_8(i+G_ni) - TWO_8*Dcst_pi_8
end do
do i=G_ni+1,2*G_ni
G_xg_8(i) = G_xg_8(i-G_ni) + TWO_8*Dcst_pi_8
end do
*
G_yg_8( 0 ) = -(G_yg_8(1) + Dcst_pi_8)
G_yg_8(-1 ) = -TWO_8*Dcst_pi_8 -
$ (G_yg_8(0)+G_yg_8(1)+G_yg_8(2))
G_yg_8(G_nj+1) = Dcst_pi_8 - G_yg_8(G_nj)
G_yg_8(G_nj+2) = TWO_8*Dcst_pi_8 -
$ (G_yg_8(G_nj+1)+G_yg_8(G_nj)+G_yg_8(G_nj-1))
do j=-2,-G_nj+1,-1
G_yg_8(j) = 1.01*G_yg_8(j+1)
end do
do j=G_nj+3,2*G_nj
G_yg_8(j) = 1.01*G_yg_8(j-1)
end do
*
*C Compute longitudes in degrees for model output
* ----------------------------------------------
do i = 1, G_ni+1
Geomn_longs(i) = G_xg_8(i) * rad2deg_8
Geomn_longu(i) = (G_xg_8(i+1)+G_xg_8(i))*HALF_8*rad2deg_8
end do
do i = 1, G_nj
Geomn_latgs(i) = G_yg_8(i) * rad2deg_8
end do
do i =1, G_njv
Geomn_latgv(i) = (G_yg_8(i+1)+G_yg_8(i))*HALF_8*rad2deg_8
end do
*
call hpalloc(Geomg_x_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_y_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_xu_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_yv_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_hx_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_hy_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_hxu_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_hyv_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_cx_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_sx_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_cy_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_cy2_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_cyv_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_cyv2_8_,LARRAY1DY, err,8)
call hpalloc(Geomg_sy_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_syv_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_hsy_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_hsyv_8_,LARRAY1DY, err,8)
call hpalloc(Geomg_wxs_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_ys_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_z_8_ , G_nk, err,8)
call hpalloc(Geomg_hz_8_ , G_nk, err,8)
call hpalloc(Geomg_dpia_ , G_nk*2, err,1)
call hpalloc(Geomg_dpib_ , G_nk*2, err,1)
call hpalloc(Geomg_invhx_8_ ,LARRAY1DX, err,8)
call hpalloc(Geomg_invhsy_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_invhsyv_8_ ,LARRAY1DY, err,8)
call hpalloc(Geomg_invz_8_ , G_nk, err,8)
*
offi = Ptopo_gindx(1,Ptopo_myproc+1)-1
offj = Ptopo_gindx(3,Ptopo_myproc+1)-1
*
do i=1-G_halox,l_ni+G_halox
indx = offi + i
Geomg_x_8 (i) = G_xg_8(indx)
Geomg_xu_8 (i) = (G_xg_8(indx+1)+ G_xg_8(indx)) * HALF_8
Geomg_hx_8 (i) = G_xg_8(indx+1)- G_xg_8(indx)
Geomg_hxu_8(i) = (G_xg_8(indx+2)- G_xg_8(indx)) * HALF_8
end do
do j=1-G_haloy,l_nj+G_haloy
indx = offj + j
Geomg_y_8 (j) = G_yg_8(indx)
Geomg_yv_8 (j) = (G_yg_8(indx+1)+ G_yg_8(indx)) * HALF_8
Geomg_hy_8 (j) = G_yg_8(indx+1)- G_yg_8(indx)
Geomg_hyv_8(j) = (G_yg_8(indx+2)- G_yg_8(indx)) * HALF_8
end do
*
*C Compute grid dependant variables
* --------------------------------
do i=1-G_halox,l_ni+G_halox
Geomg_sx_8(i) = sin( Geomg_x_8(i) )
Geomg_cx_8(i) = cos( Geomg_x_8(i) )
end do
*
do j=1-G_haloy,l_nj+G_haloy
indx = offj + j
Geomg_cy_8 (j)= cos( Geomg_y_8 (j) )
Geomg_cy2_8 (j)= cos( Geomg_y_8 (j) )**2
Geomg_cyv_8 (j)= cos( Geomg_yv_8(j) )
Geomg_cyv2_8(j)= cos( Geomg_yv_8(j) )**2
Geomg_sy_8 (j)= sin( Geomg_y_8 (j) )
Geomg_syv_8 (j)= sin( Geomg_yv_8(j) )
Geomg_hsy_8 (j)= sin( G_yg_8(indx+1))-sin(G_yg_8(indx))
Geomg_hsyv_8(j)=
$ sin((G_yg_8(indx+2)+G_yg_8(indx+1))* HALF_8)-
$ sin((G_yg_8(indx+1)+G_yg_8(indx ))* HALF_8)
end do
*
dimx = l_ni+2*G_halox
dimy = l_nj+2*G_haloy
call vrec (Geomg_invhx_8 , Geomg_hx_8 , dimx )
call vrec (Geomg_invhsy_8 , Geomg_hsy_8 , dimy )
call vrec (Geomg_invhsyv_8 , Geomg_hsyv_8, dimy )
*
*C Set variables for polar extention in diffusion operators
* --------------------------------------------------------
do i=1-G_halox,l_ni+G_halox
Geomg_wxs_8(i) = Geomg_hx_8(i)/( TWO_8 * Dcst_pi_8 )
end do
*
do j=1-G_haloy,l_nj+G_haloy
Geomg_ys_8(j) = Geomg_yv_8(j)
end do
*
do i=1,l_ni
indx = offi + i
xfi(i) = xgi_8(indx)
end do
do i=1,l_nj
indx = offj + i
yfi(i) = ygi_8(indx)
end do
*
call getenvc ('GEM_DEBUG',gem_debug)
if (gem_debug.eq.'print') then
do i=1,l_ni
print *,'PE_xpos:',Ptopo_myproc,i,xfi(i)
enddo
do i=1,l_nj
print *,'PE_ypos:',Ptopo_myproc,i,yfi(i)
enddo
endif
*
dgid = ezgdef_fmem (l_ni , l_nj , 'Z', 'E', Hgc_ig1ro,
$ Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro, xfi , yfi )
err = gdll (dgid,Geomn_latrx,Geomn_lonrx)
do j=1,l_nj
do i=1,l_ni
if (Geomn_lonrx(i,j).ge.180.0) Geomn_lonrx(i,j)=Geomn_lonrx(i,j)-360.0
enddo
enddo
*
*C Computes coriolis factor
* ------------------------
call set_cori()
*
*C Computes (u,v) interpolation coefficients for coriolis
* and right hand side computations
* ------------------------------------------------------
call set_intuv()
*
*
*C Computes vertical diffusion amplification factor
* ------------------------------------------------
if (.not.G_lam) call itf_phy_vlsp (Lun_out)
*
1000 format(/,'INITIALIZATION OF MODEL GEOMETRY (S/R SET_GEOM)',
% /'===============================================')
1005 format (/' VERTICAL LAYERING ON',I4,' HYBRID LEVELS WITH ',
$ 'Grd_rcoef= ',f10.7,':'/5x,'level #',4x,'HYB',10x,'HYBM')
1006 format (5x,i4,2(3x,f10.7))
*
* ---------------------------------------------------------------
*
return
end