source: trunk/WRF.COMMON/WRFV2/tools/gen_interp.c @ 3547

Last change on this file since 3547 was 11, checked in by aslmd, 14 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 14.0 KB
Line 
1#include <stdio.h>
2#include <stdlib.h>
3#include <string.h>
4
5#include "protos.h"
6#include "registry.h"
7#include "data.h"
8
9int contains_str( char *s1, char *s2 )
10{
11  int i ;
12  char *p, *q, *r ;
13  if ( s2 == NULL || s1 == NULL ) return ( 0 ) ;
14  if ( *s2 == '\0' || *s1 == '\0' ) return ( 0 ) ;
15  p = s1 ;
16  while ( *p ) {
17    if ((r = (char *)index( p , *s2 )) == NULL ) { return( 0 ) ; }
18    for ( q = s2 ; *q && *r == *q ; r++ , q++ )  ;
19    if ( *q == '\0' ) return (1) ;
20    p++ ;
21  }
22  return( 0 ) ;
23}
24
25int contains_tok( char *s1, char *s2, char *delims )
26{
27  char *p ;
28  char tempstr[8092] ;
29
30  strcpy( tempstr , s1 ) ;
31  p = strtok ( tempstr, delims ) ;
32  while ( p != NULL )
33  {
34    if ( !strcmp ( p , s2 ) ) {  return(1) ;}
35    p = strtok( NULL, delims ) ;
36  }
37  return(0) ;
38}
39 
40
41char halo_define[4*4096], halo_use[NAMELEN], halo_id[NAMELEN], upper_case_corename[NAMELEN], x[NAMELEN] ;
42
43int 
44gen_nest_interp ( char * dirname )
45{
46  char * corename ;
47  char * fnlst[] = { "nest_forcedown_interp.inc" , "nest_interpdown_interp.inc" , 
48                     "nest_feedbackup_interp.inc", "nest_feedbackup_smooth.inc",
49                     0L } ;
50  int down_path[] = { FORCE_DOWN , INTERP_DOWN , INTERP_UP, SMOOTH_UP } ;
51  int ipath ;
52  char ** fnp ; char * fn ;
53  char fname[NAMELEN] ;
54  FILE * fp ;
55  int i ;
56
57  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
58  {
59    fn = *fnp ;
60    for ( i = 0 ; i < get_num_cores() ; i++ )
61    {
62      corename = get_corename_i(i) ;
63      if ( dirname == NULL || corename == NULL ) return(1) ;
64      if ( strlen(dirname) > 0 )
65       { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
66      else
67       { sprintf(fname,"%s_%s",corename,fn) ; }
68      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
69      print_warning(fp,fname) ;
70
71strcpy( upper_case_corename , corename ) ;
72make_upper_case( upper_case_corename ) ;
73if      ( down_path[ipath] == INTERP_DOWN ) { sprintf(halo_id,"HALO_%s_INTERP_DOWN",upper_case_corename) ; }
74else if ( down_path[ipath] == FORCE_DOWN  ) { sprintf(halo_id,"HALO_%s_FORCE_DOWN",upper_case_corename) ; }
75else if ( down_path[ipath] == INTERP_UP   ) { sprintf(halo_id,"HALO_%s_INTERP_UP",upper_case_corename) ; }
76else if ( down_path[ipath] == SMOOTH_UP   ) { sprintf(halo_id,"HALO_%s_INTERP_SMOOTH",upper_case_corename) ; }
77sprintf(halo_define,"80:") ;
78sprintf(halo_use,"dyn_%s",corename) ;
79
80#if 0
81      gen_nest_interp1 ( fp , Domain.fields, corename, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?1:2 ) ;
82#else
83      gen_nest_interp1 ( fp , Domain.fields, corename, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 ) ;
84#endif
85
86{
87  node_t * comm_struct ;
88  comm_struct = new_node( HALO ) ;
89  strcpy( comm_struct->name        , halo_id     ) ;
90  strcpy( comm_struct->use         , halo_use    ) ;
91  strcpy( comm_struct->comm_define , halo_define ) ;
92  add_node_to_end( comm_struct , &Halos ) ;
93}
94
95
96      close_the_file(fp) ;
97    }
98  }
99  return(0) ; 
100}
101
102
103int
104gen_nest_interp1 ( FILE * fp , node_t * node, char * corename , char * fourdname, int down_path , int use_nest_time_level )
105{
106  int i, ii ;
107  char * fn = "nest_interp.inc" ;
108  char fname[NAMELEN] ;
109  node_t *p, *p1, *dim ;
110  int d2, d3, xdex, ydex, zdex, io_mask ;
111  char ddim[3][2][NAMELEN] ;
112  char mdim[3][2][NAMELEN] ;
113  char pdim[3][2][NAMELEN] ;
114  char ddim2[3][2][NAMELEN] ;
115  char mdim2[3][2][NAMELEN] ;
116  char pdim2[3][2][NAMELEN] ;
117  char nddim[3][2][NAMELEN] ;
118  char nmdim[3][2][NAMELEN] ;
119  char npdim[3][2][NAMELEN] ;
120  char nddim2[3][2][NAMELEN] ;
121  char nmdim2[3][2][NAMELEN] ;
122  char npdim2[3][2][NAMELEN] ;
123  char vname[NAMELEN] ; char vname2[NAMELEN] ; char tag[NAMELEN], tag2[NAMELEN] ; char core[NAMELEN], core2[NAMELEN] ;
124  char fcn_name[NAMELEN] ;
125  char xstag[NAMELEN], ystag[NAMELEN] ;
126  char dexes[NAMELEN] ;
127  char ndexes[NAMELEN] ;
128  char *maskstr ;
129  char *grid ;
130
131
132  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
133  {
134    if ( p1->node_kind & FOURD )
135    {
136      if ( p1->members->next ) {
137        io_mask = p1->members->next->io_mask ;
138      } else {
139        continue ;
140      }
141    }
142    else
143    {
144      io_mask = p1->io_mask ;
145    }
146    p = p1 ;
147
148    if ( io_mask & down_path )
149    {
150      if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
151      {
152
153        if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename,vname) ;
154        else                                sprintf(core,"") ;
155
156        if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; }
157        else              { sprintf(tag,"")   ; sprintf(tag2,"")                         ; }
158
159        /* construct variable name */
160        if ( p->node_kind & FOURD ) {
161
162sprintf(x, "%s%s", p->name, tag ) ;
163if ( ! contains_tok ( halo_define , x , ":," ) ) {
164 if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,p->name) ; strcat(halo_define,tag) ; }
165 else                                             { strcat(halo_define,",") ; strcat(halo_define,p->name) ; strcat(halo_define,tag) ; }
166}
167          strcpy(dexes,"grid%sm31,grid%sm32,grid%sm33") ;
168          sprintf(vname,"%s%s(%s,itrace)",p->name,tag,dexes) ;
169          strcpy(ndexes,"ngrid%sm31,ngrid%sm32,ngrid%sm33") ;
170          sprintf(vname2,"%s%s%s(%s,itrace)",core,p->name,tag2,ndexes) ;
171
172          if ( down_path & SMOOTH_UP ) {
173            strcpy( fcn_name , p->members->next->smoothu_fcn_name ) ;
174          } else {
175            strcpy( fcn_name , (down_path & INTERP_UP)?p->members->next->interpu_fcn_name:((down_path & FORCE_DOWN)?p->members->next->force_fcn_name:p->members->next->interpd_fcn_name) ) ;
176          }
177        }
178        else
179        {
180          sprintf(vname,"%s%s",p->name,tag) ;
181
182if ( ! contains_tok ( halo_define , vname  , ":," ) ) {
183 if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,vname) ; }
184 else                                             { strcat(halo_define,",") ; strcat(halo_define,vname) ; }
185}
186          sprintf(vname2,"%s%s%s",core,p->name,tag2) ;
187          if ( down_path & SMOOTH_UP ) {
188            strcpy( fcn_name , p->smoothu_fcn_name ) ;
189          } else {
190            strcpy( fcn_name , (down_path & INTERP_UP)?p->interpu_fcn_name:((down_path & FORCE_DOWN)?p->force_fcn_name:p->interpd_fcn_name) ) ;
191          }
192        }
193
194        if ( p1->node_kind & FOURD ) {
195          grid = "" ;
196          set_dim_strs ( p->members->next , ddim , mdim , pdim , "c", 1 ) ;
197          set_dim_strs ( p->members->next , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
198          set_dim_strs ( p->members->next , nddim , nmdim , npdim , "n", 1 ) ;
199          set_dim_strs ( p->members->next , nddim2 , nmdim2 , npdim2 , "n", 0 ) ;
200          zdex = get_index_for_coord( p->members->next , COORD_Z ) ;
201          xdex = get_index_for_coord( p->members->next , COORD_X ) ;
202          ydex = get_index_for_coord( p->members->next , COORD_Y ) ;
203          if ( p->members->next->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ;
204          if ( p->members->next->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ;
205          if ( p->members->next->stag_x && p->members->next->stag_y ) {
206            maskstr = "_xystag" ;
207          } else if ( p->stag_x ) {
208            maskstr = "_xstag" ;
209          } else if ( p->stag_y ) {
210            maskstr = "_ystag" ;
211          } else {
212            maskstr = "_nostag" ;
213          }
214        } else {
215          grid = "grid%" ;
216          set_dim_strs ( p , ddim , mdim , pdim , "c", 1 ) ;
217          set_dim_strs ( p , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
218          set_dim_strs ( p , nddim , nmdim , npdim , "n", 1 ) ;
219          set_dim_strs ( p , nddim2 , nmdim2 , npdim2 , "n", 0 ) ;
220          zdex = get_index_for_coord( p , COORD_Z ) ;
221          xdex = get_index_for_coord( p , COORD_X ) ;
222          ydex = get_index_for_coord( p , COORD_Y ) ;
223          if ( p->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ;
224          if ( p->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ;
225          if ( p->stag_x && p->stag_y ) {
226            maskstr = "_xystag" ;
227          } else if ( p->stag_x ) {
228            maskstr = "_xstag" ;
229          } else if ( p->stag_y ) {
230            maskstr = "_ystag" ;
231          } else {
232            maskstr = "_nostag" ;
233          }
234        }
235
236        if ( p->node_kind & FOURD )
237        {
238fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ;
239        }
240
241fprintf(fp,"CALL %s (                                                               &         \n", fcn_name ) ;
242
243        if ( zdex >= 0 ) {
244
245/* note this is only good for IKJ */
246
247fprintf(fp,"                  %s%s,                                                           &         ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ;
248fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
249                ddim[0][0], ddim[0][1], ddim[1][0], ddim[1][1], ddim[2][0], ddim[2][1] ) ;
250fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
251                mdim[0][0], mdim[0][1], mdim[1][0], mdim[1][1], mdim[2][0], mdim[2][1] ) ;
252fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
253                pdim[0][0], pdim[0][1], pdim2[1][0], pdim2[1][1], pdim[2][0], pdim[2][1] ) ;
254if ( ! (down_path  & SMOOTH_UP)  ) {
255fprintf(fp,"                  ngrid%%%s,                                                        &   ! ND field\n", vname2) ;
256}
257fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
258                nddim[0][0], nddim[0][1], nddim[1][0], nddim[1][1], nddim[2][0], nddim[2][1] ) ;
259fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
260                nmdim[0][0], nmdim[0][1], nmdim[1][0], nmdim[1][1], nmdim[2][0], nmdim[2][1] ) ;
261fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
262                npdim[0][0], npdim[0][1], npdim2[1][0], npdim2[1][1], npdim[2][0], npdim[2][1] ) ;
263
264        } else {
265
266/* note this is only good for IKJ */
267
268fprintf(fp,"                  %s%s,                                                           &         ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ;
269fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
270                ddim[0][0], ddim[0][1],          "1",         "1", ddim[1][0], ddim[1][1] ) ;
271fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
272                mdim[0][0], mdim[0][1],          "1",         "1", mdim[1][0], mdim[1][1] ) ;
273fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
274                pdim[0][0], pdim[0][1],          "1",         "1", pdim[1][0], pdim[1][1] ) ;
275if ( ! (down_path  & SMOOTH_UP)  ) {
276fprintf(fp,"                  ngrid%%%s,                                                        &   ! ND field\n", vname2) ;
277}
278fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
279                nddim[0][0], nddim[0][1],           "1",          "1", nddim[1][0], nddim[1][1] ) ;
280fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
281                nmdim[0][0], nmdim[0][1],           "1",          "1", nmdim[1][0], nmdim[1][1] ) ;
282fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
283                npdim[0][0], npdim[0][1],           "1",          "1", npdim[1][0], npdim[1][1] ) ;
284
285        }
286
287if ( ! (down_path  & SMOOTH_UP)  ) {
288  if ( sw_deref_kludge == 1 ) {
289fprintf(fp,"                  config_flags%%shw, ngrid%%imask%s(nims,njms),         &         ! stencil half width\n",maskstr) ;
290  } else {
291fprintf(fp,"                  config_flags%%shw, ngrid%%imask%s,         &         ! stencil half width\n",maskstr) ;
292  }
293}
294fprintf(fp,"                  %s, %s,                                                &         ! xstag, ystag\n", xstag, ystag ) ;
295fprintf(fp,"                  ngrid%%i_parent_start, ngrid%%j_parent_start,                     &\n") ;
296fprintf(fp,"                  ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio                &\n") ;
297   
298        {
299           char tmpstr[NAMELEN], *p1 ;
300           node_t * nd, * pp  ;
301           pp = NULL ;
302           if ( p->node_kind & FOURD ) {
303             if (  p->members->next ) {
304               pp = p->members->next ;
305             }
306           } else {
307             pp = p ;
308           }
309           if ( pp ) {
310             strcpy( tmpstr , "" ) ;
311             if        ( down_path & SMOOTH_UP ) {
312               strcpy( tmpstr , pp->smoothu_aux_fields ) ;
313             } else if ( down_path & INTERP_UP ) {
314               strcpy( tmpstr , pp->interpu_aux_fields ) ;
315             } else if ( down_path & FORCE_DOWN ) {
316               /* by default, add the boundary and boundary tendency fields to the arg list */
317               if ( ! p->node_kind & FOURD ) {
318                 sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name )  ;
319               } else {
320                 sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name )  ;
321               }
322               strcat( tmpstr , pp->force_aux_fields ) ;
323             } else if ( down_path & INTERP_DOWN ) {
324               strcpy( tmpstr , pp->interpd_aux_fields ) ;
325             }
326
327             for ( p1 = strtok(tmpstr,",") ; p1 != NULL ; p1 = strtok(NULL,",") )
328             {
329               if (( nd = get_entry ( p1 , Domain.fields )) != NULL )
330               {
331                 if (!strncmp( nd->use, "dyn_", 4))   sprintf(core2,"%s_",corename,vname) ;
332                 else                                 sprintf(core2,"") ;
333                 if ( nd->boundary_array ) {
334                   if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
335                     fprintf(fp,",%s,ngrid%%%s%s  &\n", nd->name, core2, nd->name ) ;
336                   } else {
337                     fprintf(fp,",%s%s(1,1,1,1,itrace),ngrid%%%s%s(1,1,1,1,itrace)  &\n", core2, nd->name, core2, nd->name ) ;
338                   }
339                 } else {
340                   fprintf(fp,",grid%%%s%s,ngrid%%%s%s  &\n", core2, nd->name, core2, nd->name ) ;
341                 }
342               }
343               else
344               {
345                 fprintf(stderr,"REGISTRY WARNING: Don't know about %s in definition of %s\n",p1,vname) ;
346               }
347             }
348           }
349        }
350
351fprintf(fp,"                  ) \n") ;
352
353        if ( p->node_kind & FOURD )
354        {
355fprintf(fp,"ENDDO\n") ;
356        }
357
358        }
359     }
360  }
361
362  return(0) ;
363}
364
Note: See TracBrowser for help on using the repository browser.