gen_interp.c
References to this file elsewhere.
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
9 int 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
25 int 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
41 char halo_define[4*4096], halo_use[NAMELEN], halo_id[NAMELEN], upper_case_corename[NAMELEN], x[NAMELEN] ;
42
43 int
44 gen_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
71 strcpy( upper_case_corename , corename ) ;
72 make_upper_case( upper_case_corename ) ;
73 if ( down_path[ipath] == INTERP_DOWN ) { sprintf(halo_id,"HALO_%s_INTERP_DOWN",upper_case_corename) ; }
74 else if ( down_path[ipath] == FORCE_DOWN ) { sprintf(halo_id,"HALO_%s_FORCE_DOWN",upper_case_corename) ; }
75 else if ( down_path[ipath] == INTERP_UP ) { sprintf(halo_id,"HALO_%s_INTERP_UP",upper_case_corename) ; }
76 else if ( down_path[ipath] == SMOOTH_UP ) { sprintf(halo_id,"HALO_%s_INTERP_SMOOTH",upper_case_corename) ; }
77 sprintf(halo_define,"80:") ;
78 sprintf(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
103 int
104 gen_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
162 sprintf(x, "%s%s", p->name, tag ) ;
163 if ( ! 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
182 if ( ! 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_strs2 ( p->members->next , ddim , mdim , pdim , "c", 1 ) ;
197 set_dim_strs2 ( p->members->next , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
198 set_dim_strs2 ( p->members->next , nddim , nmdim , npdim , "n", 1 ) ;
199 set_dim_strs2 ( 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_strs2 ( p , ddim , mdim , pdim , "c", 1 ) ;
217 set_dim_strs2 ( p , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
218 set_dim_strs2 ( p , nddim , nmdim , npdim , "n", 1 ) ;
219 set_dim_strs2 ( 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 {
238 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ;
239 }
240
241 fprintf(fp,"CALL %s ( & \n", fcn_name ) ;
242
243 fprintf(fp," %s%s, & ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ;
244 fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n",
245 ddim[0][0], ddim[0][1], ddim[1][0], ddim[1][1], ddim[2][0], ddim[2][1] ) ;
246 fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n",
247 mdim[0][0], mdim[0][1], mdim[1][0], mdim[1][1], mdim[2][0], mdim[2][1] ) ;
248 fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n",
249 pdim[0][0], pdim[0][1], pdim2[1][0], pdim2[1][1], pdim[2][0], pdim[2][1] ) ;
250 if ( ! (down_path & SMOOTH_UP) ) {
251 fprintf(fp," ngrid%%%s, & ! ND field\n", vname2) ;
252 }
253 fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n",
254 nddim[0][0], nddim[0][1], nddim[1][0], nddim[1][1], nddim[2][0], nddim[2][1] ) ;
255 fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n",
256 nmdim[0][0], nmdim[0][1], nmdim[1][0], nmdim[1][1], nmdim[2][0], nmdim[2][1] ) ;
257 fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n",
258 npdim[0][0], npdim[0][1], npdim2[1][0], npdim2[1][1], npdim[2][0], npdim[2][1] ) ;
259
260 if ( ! (down_path & SMOOTH_UP) ) {
261 if ( sw_deref_kludge == 1 ) {
262 fprintf(fp," config_flags%%shw, ngrid%%imask%s(nims,njms), & ! stencil half width\n",maskstr) ;
263 } else {
264 fprintf(fp," config_flags%%shw, ngrid%%imask%s, & ! stencil half width\n",maskstr) ;
265 }
266 }
267 fprintf(fp," %s, %s, & ! xstag, ystag\n", xstag, ystag ) ;
268 fprintf(fp," ngrid%%i_parent_start, ngrid%%j_parent_start, &\n") ;
269 fprintf(fp," ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio &\n") ;
270
271 {
272 char tmpstr[NAMELEN], *p1 ;
273 node_t * nd, * pp ;
274 pp = NULL ;
275 if ( p->node_kind & FOURD ) {
276 if ( p->members->next ) {
277 pp = p->members->next ;
278 }
279 } else {
280 pp = p ;
281 }
282 if ( pp ) {
283 strcpy( tmpstr , "" ) ;
284 if ( down_path & SMOOTH_UP ) {
285 strcpy( tmpstr , pp->smoothu_aux_fields ) ;
286 } else if ( down_path & INTERP_UP ) {
287 strcpy( tmpstr , pp->interpu_aux_fields ) ;
288 } else if ( down_path & FORCE_DOWN ) {
289 /* by default, add the boundary and boundary tendency fields to the arg list */
290 if ( ! p->node_kind & FOURD ) {
291 sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name ) ;
292 } else {
293 sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name ) ;
294 }
295 strcat( tmpstr , pp->force_aux_fields ) ;
296 } else if ( down_path & INTERP_DOWN ) {
297 strcpy( tmpstr , pp->interpd_aux_fields ) ;
298 }
299
300 for ( p1 = strtok(tmpstr,",") ; p1 != NULL ; p1 = strtok(NULL,",") )
301 {
302 if (( nd = get_entry ( p1 , Domain.fields )) != NULL )
303 {
304 if (!strncmp( nd->use, "dyn_", 4)) sprintf(core2,"%s_",corename,vname) ;
305 else sprintf(core2,"") ;
306 if ( nd->boundary_array ) {
307 if ( sw_new_bdys ) {
308 int bdy ;
309 for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
310 if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
311 fprintf(fp,",%s%s,ngrid%%%s%s%s &\n", nd->name, bdy_indicator(bdy), core2, nd->name, bdy_indicator(bdy) ) ;
312 } else {
313 char c ;
314 c = 'i' ; if ( bdy <= 2 ) c = 'j' ;
315 fprintf(fp,",%s%s%s(c%cms,1,1,itrace),ngrid%%%s%s%s(n%cms,1,1,itrace) &\n", core2, nd->name, bdy_indicator(bdy), c, core2, nd->name, bdy_indicator(bdy), c ) ;
316 }
317 }
318 } else {
319 if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
320 fprintf(fp,",%s,ngrid%%%s%s &\n", nd->name, core2, nd->name ) ;
321 } else {
322 fprintf(fp,",%s%s(1,1,1,1,itrace),ngrid%%%s%s(1,1,1,1,itrace) &\n", core2, nd->name, core2, nd->name ) ;
323 }
324 }
325 } else {
326 fprintf(fp,",grid%%%s%s,ngrid%%%s%s &\n", core2, nd->name, core2, nd->name ) ;
327 }
328 }
329 else
330 {
331 fprintf(stderr,"REGISTRY WARNING: Don't know about %s in definition of %s\n",p1,vname) ;
332 }
333 }
334 }
335 }
336
337 fprintf(fp," ) \n") ;
338
339 if ( p->node_kind & FOURD )
340 {
341 fprintf(fp,"ENDDO\n") ;
342 }
343
344 }
345 }
346 }
347
348 return(0) ;
349 }
350