source: lmdz_wrf/trunk/WRFV3/tools/gen_interp.c @ 354

Last change on this file since 354 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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