6 #define rindex(X,Y) strrchr(X,Y)
7 #define index(X,Y) strchr(X,Y)
14 int contains_str( char *s1
, char *s2
)
18 if ( s2
== NULL
|| s1
== NULL
) return ( 0 ) ;
19 if ( *s2
== '\0' || *s1
== '\0' ) return ( 0 ) ;
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) ;
30 int contains_tok( char *s1
, char *s2
, char *delims
)
35 strcpy( tempstr
, s1
) ;
36 p
= strtok ( tempstr
, delims
) ;
39 if ( !strcmp ( p
, s2
) ) { return(1) ;}
40 p
= strtok( NULL
, delims
) ;
46 /* Had to increase size for SOA from 4*4096 to 4*7000 */
47 char halo_define
[4*7000], halo_use
[NAMELEN
], halo_id
[NAMELEN
], x
[NAMELEN
] ;
50 gen_nest_interp ( char * dirname
)
52 char * fnlst
[] = { "nest_forcedown_interp.inc" , "nest_interpdown_interp.inc" ,
53 "nest_feedbackup_interp.inc", "nest_feedbackup_smooth.inc",
55 int down_path
[] = { FORCE_DOWN
, INTERP_DOWN
, INTERP_UP
, SMOOTH_UP
} ;
57 char ** fnp
; char * fn
;
61 for ( fnp
= fnlst
, ipath
= 0 ; *fnp
; fnp
++ , ipath
++ )
64 if ( dirname
== NULL
) return(1) ;
65 if ( strlen(dirname
) > 0 )
66 { sprintf(fname
,"%s/%s",dirname
,fn
) ; }
68 { sprintf(fname
,"%s",fn
) ; }
69 if ((fp
= fopen( fname
, "w" )) == NULL
) return(1) ;
70 print_warning(fp
,fname
) ;
72 if ( down_path
[ipath
] == INTERP_DOWN
) { sprintf(halo_id
,"HALO_INTERP_DOWN") ; }
73 else if ( down_path
[ipath
] == FORCE_DOWN
) { sprintf(halo_id
,"HALO_FORCE_DOWN") ; }
74 else if ( down_path
[ipath
] == INTERP_UP
) { sprintf(halo_id
,"HALO_INTERP_UP") ; }
75 else if ( down_path
[ipath
] == SMOOTH_UP
) { sprintf(halo_id
,"HALO_INTERP_SMOOTH") ; }
76 sprintf(halo_define
,"80:") ;
77 sprintf(halo_use
,"") ;
78 gen_nest_interp1 ( fp
, Domain
.fields
, NULL
, down_path
[ipath
], (down_path
[ipath
]==FORCE_DOWN
)?2:2 ) ;
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
) ;
96 gen_nest_interp1 ( FILE * fp
, node_t
* node
, char * fourdname
, int down_path
, int use_nest_time_level
)
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
] ;
123 char *colon
, r
[10],tx
[80],temp
[80],moredims
[80] ;
127 for ( p1
= node
; p1
!= NULL
; p1
= p1
->next
)
129 if ( p1
->node_kind
& FOURD
)
131 if ( p1
->members
->next
) {
132 nest_mask
= p1
->members
->next
->nest_mask
;
139 nest_mask
= p1
->nest_mask
;
143 if ( nest_mask
& down_path
)
145 if ( p
->ntl
> 1 ) { sprintf(tag
,"_2") ; sprintf(tag2
,"_%d", use_nest_time_level
) ; }
146 else { sprintf(tag
,"") ; sprintf(tag2
,"") ; }
148 /* construct variable name */
149 if ( p
->node_kind
& FOURD
) {
151 sprintf(x
, "%s%s", p
->name
, tag
) ;
152 if ( ! 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
) ; }
156 strcpy(moredims
,"") ;
157 for ( d
= 3 ; d
< p
->ndims
; d
++ ) {
158 sprintf(temp
,"idim%d",d
-2) ;
159 strcat(moredims
,",") ; strcat(moredims
,temp
) ;
161 strcat(moredims
,",") ;
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
) ;
168 if ( down_path
& SMOOTH_UP
) {
169 strcpy( fcn_name
, p
->members
->next
->smoothu_fcn_name
) ;
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
) ) ;
176 sprintf(vname
,"%s%s",p
->name
,tag
) ;
178 if ( ! 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
) ; }
182 sprintf(vname2
,"%s%s",p
->name
,tag2
) ;
183 if ( down_path
& SMOOTH_UP
) {
184 strcpy( fcn_name
, p
->smoothu_fcn_name
) ;
186 strcpy( fcn_name
, (down_path
& INTERP_UP
)?p
->interpu_fcn_name
:((down_path
& FORCE_DOWN
)?p
->force_fcn_name
:p
->interpd_fcn_name
) ) ;
190 if ( p1
->node_kind
& FOURD
) {
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
) {
205 } else if ( p
->stag_y
) {
208 maskstr
= "_nostag" ;
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
) {
225 } else if ( p
->stag_y
) {
228 maskstr
= "_nostag" ;
232 if ( p
->node_kind
& FOURD
)
234 fprintf(fp
,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p
->name
) ;
235 for ( d
= p
->ndims
-1 ; d
>= 3 ; d
-- ) {
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
) ;
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 ) ;
245 if ( !strcmp( fcn_name
, "interp_mask_land_field" ) ||
246 !strcmp( fcn_name
, "interp_mask_water_field" ) ) {
247 fprintf(fp
,"IF ( .TRUE. ) THEN \n") ;
249 fprintf(fp
,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1 ) THEN \n", grid
,vname2
,xdex
+1,grid
,vname2
,ydex
+1 ) ;
253 fprintf(fp
,"CALL %s ( & \n", fcn_name
) ;
255 if ( !strcmp( fcn_name
, "interp_mask_land_field" ) || !strcmp( fcn_name
, "interp_mask_water_field" ) ) {
256 fprintf(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
) ;
259 fprintf(fp
," %s%s, & ! CD field\n", grid
, (p
->node_kind
& FOURD
)?vname
:vname2
) ;
260 fprintf(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] ) ;
262 fprintf(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] ) ;
264 fprintf(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] ) ;
266 if ( ! (down_path
& SMOOTH_UP
) ) {
267 fprintf(fp
," ngrid%%%s, & ! ND field\n", vname2
) ;
269 fprintf(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] ) ;
271 fprintf(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] ) ;
273 fprintf(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] ) ;
276 if ( ! (down_path
& SMOOTH_UP
) ) {
277 if ( sw_deref_kludge
== 1 ) {
278 fprintf(fp
," config_flags%%shw, ngrid%%imask%s(nims,njms), & ! stencil half width\n",maskstr
) ;
280 fprintf(fp
," config_flags%%shw, ngrid%%imask%s, & ! stencil half width\n",maskstr
) ;
283 fprintf(fp
," %s, %s, & ! xstag, ystag\n", xstag
, ystag
) ;
284 fprintf(fp
," ngrid%%i_parent_start, ngrid%%j_parent_start, &\n") ;
285 fprintf(fp
," ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio &\n") ;
288 char tmpstr
[NAMELEN
], *p1
;
291 if ( p
->node_kind
& FOURD
) {
292 if ( p
->members
->next
) {
293 pp
= p
->members
->next
;
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
) ;
309 sprintf( tmpstr
, "%s_b,%s_bt,", p
->name
, p
->name
) ;
311 strcat( tmpstr
, pp
->force_aux_fields
) ;
312 } else if ( down_path
& INTERP_DOWN
) {
313 strcpy( tmpstr
, pp
->interpd_aux_fields
) ;
316 for ( p1
= strtok(tmpstr
,",") ; p1
!= NULL
; p1
= strtok(NULL
,",") )
318 if (( nd
= get_entry ( p1
, Domain
.fields
)) != NULL
)
320 if ( nd
->boundary_array
) {
323 for ( bdy
= 1 ; bdy
<= 4 ; bdy
++ ) {
324 if ( strcmp( nd
->use
, "_4d_bdy_array_" ) ) {
326 fprintf(fp
,",%s%s,ngrid%%%s%s &\n", nd
->name
, bdy_indicator(bdy
), nd
->name
, bdy_indicator(bdy
) ) ;
328 fprintf(fp
,",dummy_%s,ngrid%%%s%s &\n",
330 nd
->name
, bdy_indicator(bdy
) ) ;
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
) ;
341 if ( strcmp( nd
->use
, "_4d_bdy_array_" ) ) {
342 fprintf(fp
,",%s,ngrid%%%s &\n", nd
->name
, nd
->name
) ;
344 fprintf(fp
,",%s(1,1,1,1,itrace),ngrid%%%s(1,1,1,1,itrace) &\n", nd
->name
, nd
->name
) ;
348 fprintf(fp
,",grid%%%s,ngrid%%%s &\n", nd
->name
, nd
->name
) ;
353 fprintf(stderr
,"REGISTRY WARNING: Don't know about %s in definition of %s\n",p1
,vname
) ;
359 fprintf(fp
," ) \n") ;
361 if ( p
->node_kind
& FOURD
)
363 fprintf(fp
,"ENDIF\n") ;
364 for ( d
= p
->ndims
-1 ; d
>= 3 ; d
-- ) {
365 fprintf(fp
,"ENDDO\n") ;
367 fprintf(fp
,"ENDDO\n") ;
369 fprintf(fp
,"ENDIF\n") ; /* in_use_from_config */