!-------------------------------------- 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/p set_grid - initialization of common block GRID
*
#include "model_macros_f.h"
*
integer function set_grid (F_argc,F_argv_S,F_cmdtyp_S,F_v1,F_v2),1
implicit none
integer F_argc,F_v1,F_v2
character *(*) F_argv_S(0:F_argc),F_cmdtyp_S
character*5 stuff_S
*
*author
* Vivian Lee - rpn - April 1999
*
*revision
* v2_00 - Lee V. - initial MPI version
* v2_21 - Lee V. - modifications for LAM version and grid '#'
* v2_30 - Lee V. - ig3 is used for diese grids only
* v2_30 - ig1 to be (1,2,3...) for each defined grid
* v2_30 ig1 to be (11,12,13...) for each defined LAM grid
* v2_30 - Dugas B. - ipig now uses a real*8 rotation matrix
* v2_32 - Lee V. - gridset is now an ID defined by the user, not the
* v2_32 actual "set" number forced to be in sequence
* v3_00 - Desgagne & Lee - Lam configuration
* v3_30 - McTaggart-Cowan R.- parse optional tag extension from string
* v3_31 - Lee V. - correction for if no tag extension provided
*
*object
* initialization of the common block GRID. This function is
* called when the keyword "grid" is found in the first word
* of the directives in the input file given in the statement
* "process_f_callback". This feature is enabled by the
* ARMNLIB "rpn_fortran_callback" routine (called in "srequet")
* which allows a different way of passing user directives than
* the conventional FORTRAN namelist. This function will process
* the following example command read from the named input file.
*
* ie: grid=1,model;
*
* The "rpn_fortran_callback" routine will process the above
* statement and return 5 arguments to this function. For more
* information to how this is processed, see "SREQUET".
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_argc I - number of elements in F_argv_S
* F_argv_S I - array of elements received
* F_cmdtyp_S I - character command type - not used
* F_v1 I - integer parameter 1 - not used
* F_v2 I - integer parameter 2 - not used
*----------------------------------------------------------------
*
*Notes:
*
* examples:
* grid=4,model;
* grid=2,core;
* grid=1,reduc,4,10,4,10,2
* grid=3,reduc,4,10,4,10
* grid=5,reduc,"NEW",2,11,2,15
* grid=7,core,"CO";
*
* general syntax
* grid=gridid,[model/core/reduc],["etik"],[gridx0,gridx1,gridy0,gridy1];
*
* gridid - number to identify gridset to relate to sortie statement
* model - total grid of the model,in LAM, this includes pilot area
* core - only the uniform part of the grid, in LAM, excludes pilot are
* reduc - reduced grid from the model defined as follows
* gridx0 - starting I value along X
* gridx1 - ending I value along X
* gridy0 - starting J value along X
* gridy1 - ending J value along X
*
* IMPORTANT NOTE:
* Limit the number of definitions for "grid" to improve the efficiency
* in the output routines. The maximum number of definitions is 4.
*
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "lun.cdk"
#include "grd.cdk"
#include "grid.cdk"
*
**
integer i, j, k, gridset,gridout(5),niout,njout,longueur
external longueur
character*8 grdtyp_S
*
*-------------------------------------------------------------------
*
if (Lun_out.gt.0) then
write(Lun_out,*)
write(Lun_out,*) F_argv_S(0),'=',F_argv_S(1),',',F_argv_S(2),',',(F_argv_S(i),i=3,F_argc)
endif
set_grid = 0
read(F_argv_S(1),*) gridset
Grid_sets = Grid_sets + 1
if (Grid_sets.gt.MAXGRID1) then
if (Lun_out.gt.0)
$ write(Lun_out,*)'SET_GRID WARNING: Too many grid definitions'
Grid_sets = Grid_sets - 1
set_grid = 1
return
endif
j = Grid_sets
Grid_id(j)=gridset
Grid_etikext_S(j) = ''
if(index(F_argv_S(2),'model') .ne. 0) then
grdtyp_S='model'
if (F_argc.gt.2.and.index(F_argv_S(3),'"').gt.0)
% Grid_etikext_S(j) = F_argv_S(3)(2:longueur(F_argv_S(3))-1)
else if (index(F_argv_S(2),'core') .ne. 0) then
grdtyp_S='core'
if (F_argc.gt.2.and.index(F_argv_S(3),'"').gt.0)
% Grid_etikext_S(j) = F_argv_S(3)(2:longueur(F_argv_S(3))-1)
else if (index(F_argv_S(2),'reduc') .ne. 0) then
grdtyp_S='reduc'
gridout(1)=0
gridout(2)=0
gridout(3)=0
gridout(4)=0
gridout(5)=1
read(F_argv_S(3),*)gridout(1)
read(F_argv_S(4),*)gridout(2)
read(F_argv_S(5),*)gridout(3)
read(F_argv_S(6),*)gridout(4)
if (F_argc.gt.6) then
if (index(F_argv_S(7),'"').eq.0) read(F_argv_S(7),*)gridout(5)
if (index(F_argv_S(F_argc),'"').gt.0)
% Grid_etikext_S(j) = F_argv_S(F_argc)(2:longueur(F_argv_S(F_argc))-1)
endif
else
if (Lun_out.gt.0)
$ write(Lun_out,*)'SET_GRID WARNING: Grid Type Undefined'
Grid_sets = Grid_sets - 1
set_grid = 1
return
endif
* Get values for ip1,ip2,ip3 for the positional records which
* is also the ig1,ig2,ig3 for the scalar grid
* Note the result of Grid_ig3 is invalid because it is determined
* by dieseig34
call ipig(Grid_ig1(j), Grid_ig2(j), Grid_ig3(j),
% Grd_dx, Grd_dy, Grd_nila, Grd_njla, G_ni, G_nj,
% Grd_rot_8, Grd_roule)
Grid_ig1(j) = Grid_ig1(j) + j-1
if (G_lam) Grid_ig1(j)=Grid_ig1(j)+10
if (grdtyp_S.eq.'reduc') Grid_ig1(j)=Grid_ig1(j)+10
* Calculate the origin and outer coordinates of the output grid
* and set to the maximum/minimum possible
*
Grid_stride(j)=1
if (grdtyp_S.eq.'model') then
Grid_x0(j)=1
Grid_x1(j)=G_ni
Grid_y0(j)=1
Grid_y1(j)=G_nj
else if (grdtyp_S.eq.'core') then
*
Grid_x0(j)=Grd_left+ 1 + Lam_pil_w
Grid_x1(j)=Grd_left + Grd_nila - Lam_pil_e
Grid_y0(j)=Grd_belo + 1 + Lam_pil_s
Grid_y1(j)=Grd_belo + Grd_njla - Lam_pil_n
else if (grdtyp_S.eq.'reduc') then
Grid_x0(j)=min( G_ni, max(1,gridout(1)) )
Grid_x1(j)=max( Grid_x0(j), min(G_ni,gridout(2)) )
Grid_y0(j)=min( G_nj, max(1,gridout(3)) )
Grid_y1(j)=max( Grid_y0(j), min(G_nj,gridout(4)) )
Grid_stride(j)=min( max(gridout(5),1),
$ min(Grid_x1(j)-Grid_x0(j)+1,Grid_y1(j)-Grid_y0(j)+1)/2-1 )
endif
niout=Grid_x1(j) - Grid_x0(j) + 1
njout=Grid_y1(j) - Grid_y0(j) + 1
if (niout.lt.1.or.njout.lt.1) then
Grid_sets = Grid_sets - 1
if (Lun_out.gt.0)
$ write (Lun_out,*)'ERROR in description of output grid!'
return
endif
*
if (Lun_out.gt.0) then
write(Lun_out,*) ' Grid_set(',j,') : Grid_id=',Grid_id(j)
endif
*
*-------------------------------------------------------------------
*
return
end