!-------------------------------------- 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 --------------------------------------
copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r out_sgrid - to setup output grid
*
subroutine out_sgrid ( F_x0,F_x1,F_y0,F_y1,F_periodx_L, 12
$ F_ig1,F_ig2,F_reduc,F_etikext_s,
$ F_etikadd_S,F_xpos,F_ypos)
implicit none
*
integer F_x0, F_x1,F_y0,F_y1,F_ig1,F_ig2,F_reduc,NI,NJ
real F_xpos(*),F_ypos(*)
logical F_periodx_L
character*(*) F_etikext_s, F_etikadd_S
*
*AUTHOR Michel Desgagne July 2004
*
*REVISION
* v3_20 - Lee V. - Adapted for GEMDM
* v3_30 - McTaggart-Cowan R.- Append user defined grid tag to namelist value
* v3_31 - Lee V. - modification of Out_etik_S in out_sgrid only
*
*
*ARGUMENTS
* NAMES I/O TYPE DESCRIPTION
* F_x0 I int g_id
* F_x1 I int g_if
* F_y0 I int g_jd
* F_y1 I int g_jf
* F_reduc I int g_reduc
* F_xpos I real values for positional parameters on X
* F_ypos I real values for positional parameters on Y
* F_ig1 I int given by model
* F_ig2 I int given by model
* F_periodx I logic periodicity on X
* F_etikext_s I char grid-specific tag extension
*
#include "out.cdk"
*
integer i,bnd_w,bnd_e,bnd_s,bnd_n
integer longueur
external longueur
**
*----------------------------------------------------------------------
*
bnd_w = 1 - Out_blocwest * Out_hx
bnd_e = Out_blocni + Out_bloceast * Out_hx
bnd_s = 1 - Out_blocsouth * Out_hy
bnd_n = Out_blocnj + Out_blocnorth * Out_hy
out_reduc= F_reduc
Out_gridi0=F_x0
Out_gridin=F_x1
Out_gridj0=F_y0
Out_gridjn=F_y1
out_idl = max(F_x0 - out_bloci0 + 1, bnd_w)
out_ifl = min(F_x1 - out_bloci0 + 1, bnd_e)
out_jdl = max(F_y0 - out_blocj0 + 1, bnd_s)
out_jfl = min(F_y1 - out_blocj0 + 1, bnd_n)
*
out_nisg = 0
out_njsg = 0
out_nisl = 0
out_njsl = 0
if ((out_idl.le.bnd_e).and.(out_ifl.ge.bnd_w).and.
$ (out_jdl.le.bnd_n).and.(out_jfl.ge.bnd_s) ) then
out_idg = out_idl + out_bloci0 - F_x0
out_ifg = out_ifl + out_bloci0 - F_x0
out_jdg = out_jdl + out_blocj0 - F_y0
out_jfg = out_jfl + out_blocj0 - F_y0
out_nisg = (F_x1 - F_x0) / out_reduc + 1
out_njsg = (F_y1 - F_y0) / out_reduc + 1
out_nisl = (out_ifg - out_idg) / out_reduc + 1
out_njsl = (out_jfg - out_jdg) / out_reduc + 1
endif
if (F_periodx_L) Out_nisg=Out_nisg+1
*
if ((out_nisl.gt.0).and.(out_njsl.gt.0)) then
*
Out_ig1 = F_ig1
Out_ig2 = F_ig2
Out_ig3 = out_idg
Out_ig4 = out_jdg
*
Out_xpos_ = loc(F_xpos(1))
Out_ypos_ = loc(F_ypos(1))
endif
*
Out_etik_S = Out_etiket_S(1:min(len_trim(Out_etiket_S),
$ len(Out_etiket_S)-len_trim(F_etikext_s))) //trim(F_etikext_s)
if (F_etikadd_S.ne.' ') Out_etik_S =
$ Out_etik_S(1: min(longueur(Out_etik_S),12-longueur(F_etikadd_S)))//F_etikadd_S
*
*----------------------------------------------------------------------
return
end