source: trunk/WRF.COMMON/WRFV3/tools/gen_interp.c @ 3094

Last change on this file since 3094 was 2759, checked in by aslmd, 2 years ago

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