gen_allocs.c
References to this file elsewhere.
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <string.h>
4 #include <strings.h>
5
6 #include "protos.h"
7 #include "registry.h"
8 #include "data.h"
9
10 int
11 gen_alloc ( char * dirname )
12 {
13 int i ;
14
15 for ( i = 0 ; i < get_num_cores() ; i++ )
16 {
17 gen_alloc1( dirname , get_corename_i(i) ) ;
18 gen_ddt_write( dirname, get_corename_i(i) ) ;
19 }
20 return(0) ;
21 }
22
23 int
24 gen_alloc1 ( char * dirname , char * corename )
25 {
26 FILE * fp ;
27 char fname[NAMELEN] ;
28 char * fn = "_allocs.inc" ;
29
30 if ( dirname == NULL || corename == NULL ) return(1) ;
31 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
32 else { sprintf(fname,"%s%s",corename,fn) ; }
33 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
34 print_warning(fp,fname) ;
35 gen_alloc2( fp , "grid%", corename , &Domain, 1 ) ;
36 close_the_file( fp ) ;
37 return(0) ;
38 }
39
40 int
41 gen_alloc2 ( FILE * fp , char * structname , char * corename , node_t * node, int sw ) /* 1 = allocate, 2 = just count */
42 {
43 node_t * p ;
44 int tag ;
45 char post[NAMELEN], post_for_count[NAMELEN] ;
46 char fname[NAMELEN] ;
47 char x[NAMELEN] ;
48 char tchar ;
49
50 if ( node == NULL ) return(1) ;
51
52 for ( p = node->fields ; p != NULL ; p = p->next )
53 {
54 if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */
55 (p->node_kind & FOURD) || /* scalar arrays or... */
56 /* if it's a core specific field and we're doing that core or... */
57 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
58 /* it is not a core specific field */
59 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
60 ))
61 {
62 if ( p->type != NULL ) {
63 tchar = '?' ;
64 if ( !strcmp( p->type->name , "real" ) ) { tchar = 'R' ; }
65 else if ( !strcmp( p->type->name , "doubleprecision" ) ) { tchar = 'D' ; }
66 else if ( !strcmp( p->type->name , "logical" ) ) { tchar = 'L' ; }
67 else if ( !strcmp( p->type->name , "integer" ) ) { tchar = 'I' ; }
68 else { fprintf(stderr,"WARNING: what is the type for %s ?\n", p->name) ; }
69 }
70 if ( p->node_kind & FOURD ) { sprintf(post, ",num_%s)",field_name(t4,p,0)) ;
71 sprintf(post_for_count, "*num_%s)",field_name(t4,p,0)) ; }
72 else { sprintf(post, ")" ) ;
73 sprintf(post_for_count, ")" ) ; }
74 for ( tag = 1 ; tag <= p->ntl ; tag++ )
75 {
76 /* if this is a core-specific variable, prepend the name of the core to */
77 /* the variable at the driver level */
78 if (!strncmp("dyn_",p->use,4)&&!strcmp( corename , p->use+4 )) {
79 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
80 } else if ( !strcmp ( p->use , "_4d_bdy_array_") ) {
81 strcpy(fname,p->name) ;
82 } else {
83 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
84 }
85
86 /* check for errors in memory allocation */
87
88 fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ;
89 if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
90 ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) )
91 {
92 fprintf(fp,".AND.(.NOT.inter_domain)",tag) ;
93 }
94 if ( p->ntl > 1 && sw == 1 ) {
95 fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ;
96 }
97 fprintf(fp,")THEN\n") ;
98 if ( p->boundary_array && sw_new_bdys ) {
99 int bdy ;
100 for ( bdy = 1 ; bdy <= 4 ; bdy++ )
101 {
102 if( p->type != NULL && tchar != '?' ) {
103 fprintf(fp," num_bytes_allocated = num_bytes_allocated + (%s) * %cWORDSIZE\n",
104 array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"),
105 tchar) ;
106 }
107 if ( sw == 1 ) {
108 fprintf(fp, " ALLOCATE(%s%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n endif\n",
109 structname, fname, bdy_indicator(bdy),
110 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"),
111 structname, fname, bdy_indicator(bdy),
112 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"));
113 fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy));
114 if( p->type != NULL && (!strcmp( p->type->name , "real" )
115 || !strcmp( p->type->name , "doubleprecision") ) ) {
116 /* if a real */
117 fprintf(fp, "initial_data_value\n");
118 } else if ( !strcmp( p->type->name , "logical" ) ) {
119 fprintf(fp, ".FALSE.\n");
120 } else if ( !strcmp( p->type->name , "integer" ) ) {
121 fprintf(fp, "0\n");
122 }
123 }
124 }
125 } else {
126 if( p->type != NULL && tchar != '?' ) {
127 fprintf(fp," num_bytes_allocated = num_bytes_allocated + (%s) * %cWORDSIZE\n",
128 array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
129 tchar) ;
130 }
131 if ( sw == 1 ) {
132 fprintf(fp, " ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n",
133 structname, fname,
134 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"),
135 structname, fname,
136 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"));
137 fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
138
139 if( p->type != NULL && (!strcmp( p->type->name , "real" )
140 || !strcmp( p->type->name , "doubleprecision") ) ) {
141 /* if a real */
142 fprintf(fp, "initial_data_value\n");
143 } else if ( !strcmp( p->type->name , "logical" ) ) {
144 fprintf(fp, ".FALSE.\n");
145 } else if ( !strcmp( p->type->name , "integer" ) ) {
146 fprintf(fp, "0\n");
147 }
148 }
149 }
150
151 fprintf(fp,"ELSE\n") ;
152
153 if ( p->boundary_array && sw_new_bdys ) {
154 int bdy ;
155 for ( bdy = 1 ; bdy <= 4 ; bdy++ )
156 {
157 fprintf(fp, " ALLOCATE(%s%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n endif\n",
158 structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ),
159 structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ;
160 }
161 } else {
162 fprintf(fp, " ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n",
163 structname, fname, dimension_with_ones( "(",t2,p,")" ),
164 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
165
166 }
167
168 fprintf(fp,"ENDIF\n") ;
169
170 }
171 }
172 if ( p->type != NULL )
173 {
174 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
175 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
176 (!strcmp(p->type->name,"integer") ||
177 !strcmp(p->type->name,"logical") ||
178 !strcmp(p->type->name,"real") ||
179 !strcmp(p->type->name,"doubleprecision"))
180 )
181 {
182 if (!strncmp( "dyn_" , p->use , 4 ))
183 {
184 if (!strcmp( corename , p->use+4 ))
185 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
186 }
187 else
188 {
189 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
190 }
191 if ( sw == 1 ) {
192 if( !strcmp( p->type->name , "real" ) ||
193 !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */
194 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
195 structname ,
196 fname ) ;
197 } else if ( !strcmp( p->type->name , "integer" ) ) {
198 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
199 structname ,
200 fname ) ;
201 } else if ( !strcmp( p->type->name , "logical" ) ) {
202 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
203 structname ,
204 fname ) ;
205 }
206 }
207 }
208 else if ( p->type->type_type == DERIVED )
209 {
210 sprintf(x,"%s%s%%",structname,p->name ) ;
211 gen_alloc2(fp,x, corename, p->type, sw) ;
212 }
213 }
214 }
215 return(0) ;
216 }
217
218 int
219 gen_alloc_count ( char * dirname )
220 {
221 int i ;
222
223 for ( i = 0 ; i < get_num_cores() ; i++ )
224 {
225 gen_alloc_count1( dirname , get_corename_i(i) ) ;
226 }
227 return(0) ;
228 }
229
230 int
231 gen_alloc_count1 ( char * dirname , char * corename )
232 {
233 FILE * fp ;
234 char fname[NAMELEN] ;
235 char * fn = "_alloc_count.inc" ;
236
237 if ( dirname == NULL || corename == NULL ) return(1) ;
238 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
239 else { sprintf(fname,"%s%s",corename,fn) ; }
240 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
241 print_warning(fp,fname) ;
242 gen_alloc2( fp , "grid%", corename , &Domain, 0 ) ;
243 close_the_file( fp ) ;
244 return(0) ;
245 }
246
247 int
248 gen_ddt_write ( char * dirname , char * corename )
249 {
250 FILE * fp ;
251 char fname[NAMELEN] ;
252 char * fn = "_write_ddt.inc" ;
253
254 if ( dirname == NULL || corename == NULL ) return(1) ;
255 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
256 else { sprintf(fname,"%s%s",corename,fn) ; }
257 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
258 print_warning(fp,fname) ;
259 gen_ddt_write1( fp , "grid%", corename , &Domain ) ;
260 close_the_file( fp ) ;
261 return(0) ;
262 }
263
264 int
265 gen_ddt_write1 ( FILE * fp , char * structname , char * corename , node_t * node )
266 {
267 node_t * p ;
268 int tag ;
269 char post[NAMELEN] ;
270 char fname[NAMELEN] ;
271 char x[NAMELEN] ;
272
273 if ( node == NULL ) return(1) ;
274
275 for ( p = node->fields ; p != NULL ; p = p->next )
276 {
277 if ( (p->ndims > 1 && ! p->boundary_array) && ( /* any array or a boundary array and... */
278 (p->node_kind & FOURD) || /* scalar arrays or... */
279 /* if it's a core specific field and we're doing that core or... */
280 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
281 /* it is not a core specific field */
282 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
283 ))
284 {
285 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
286 else { sprintf(post,")") ; }
287 for ( tag = 1 ; tag <= p->ntl ; tag++ )
288 {
289 /* if this is a core-specific variable, prepend the name of the core to */
290 /* the variable at the driver level */
291 if (!strncmp("dyn_",p->use,4)&&!strcmp( corename , p->use+4 ))
292 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
293 else
294 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
295
296 if ( p->node_kind & FOURD ) {
297 fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
298 } else {
299 if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
300 if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
301 }
302
303 }
304 }
305 #if 0
306 if ( p->type != NULL )
307 {
308 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
309 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
310 (!strcmp(p->type->name,"integer") ||
311 !strcmp(p->type->name,"real") ||
312 !strcmp(p->type->name,"doubleprecision"))
313 )
314 {
315 if (!strncmp( "dyn_" , p->use , 4 ))
316 {
317 if (!strcmp( corename , p->use+4 ))
318 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
319 }
320 else
321 {
322 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
323 }
324 fprintf(fp, "write(iunit)%s%s\n",structname,fname) ;
325 }
326 }
327 #endif
328 }
329 return(0) ;
330 }
331
332 int
333 gen_dealloc ( char * dirname )
334 {
335 int i ;
336
337 for ( i = 0 ; i < get_num_cores() ; i++ )
338 {
339 gen_dealloc1( dirname , get_corename_i(i) ) ;
340 }
341 return(0) ;
342 }
343
344 int
345 gen_dealloc1 ( char * dirname , char * corename )
346 {
347 FILE * fp ;
348 char fname[NAMELEN] ;
349 char * fn = "_deallocs.inc" ;
350
351 if ( dirname == NULL || corename == NULL ) return(1) ;
352 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
353 else { sprintf(fname,"%s%s",corename,fn) ; }
354 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
355 print_warning(fp,fname) ;
356 gen_dealloc2( fp , "grid%", corename , &Domain ) ;
357 close_the_file( fp ) ;
358 return(0) ;
359 }
360
361 int
362 gen_dealloc2 ( FILE * fp , char * structname , char * corename , node_t * node )
363 {
364 node_t * p ;
365 int tag ;
366 char post[NAMELEN] ;
367 char fname[NAMELEN] ;
368 char x[NAMELEN] ;
369
370 if ( node == NULL ) return(1) ;
371
372 for ( p = node->fields ; p != NULL ; p = p->next )
373 {
374 if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */
375 (p->node_kind & FOURD) || /* scalar arrays or... */
376 /* if it's a core specific field and we're doing that core or... */
377 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
378 /* it is not a core specific field */
379 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
380 ))
381 {
382 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
383 else { sprintf(post,")") ; }
384 for ( tag = 1 ; tag <= p->ntl ; tag++ )
385 {
386 /* if this is a core-specific variable, prepend the name of the core to */
387 /* the variable at the driver level */
388 if (!strncmp("dyn_",p->use,4)&&!strcmp( corename , p->use+4 ))
389 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
390 else
391 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
392
393 if ( p->boundary && sw_new_bdys ) {
394 { int bdy ;
395 for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
396 fprintf(fp,
397 "IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
398 fprintf(fp,
399 " DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s%s. ')\n endif\n",
400 structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ;
401 fprintf(fp,
402 " NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ;
403 fprintf(fp,
404 "ENDIF\n" ) ;
405 }
406 }
407 } else {
408 fprintf(fp,
409 "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
410 fprintf(fp,
411 " DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s. ')\n endif\n",
412 structname, fname, structname, fname ) ;
413 fprintf(fp,
414 " NULLIFY(%s%s)\n",structname, fname ) ;
415 fprintf(fp,
416 "ENDIF\n" ) ;
417 }
418
419
420 }
421 }
422 if ( p->type != NULL )
423 {
424 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
425 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
426 (!strcmp(p->type->name,"integer") ||
427 !strcmp(p->type->name,"real") ||
428 !strcmp(p->type->name,"doubleprecision"))
429 )
430 {
431 }
432 else if ( p->type->type_type == DERIVED )
433 {
434 sprintf(x,"%s%s%%",structname,p->name ) ;
435 gen_dealloc2(fp,x, corename, p->type) ;
436 }
437 }
438 }
439 return(0) ;
440 }