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 ( !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 if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
89 ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) )
90 {
91 fprintf(fp,"IF(.NOT.inter_domain)THEN\n",tag) ;
92 }
93 if ( p->ntl > 1 && sw == 1 ) {
94 fprintf(fp,"IF(IAND(%d,tl).NE.0)THEN\n",tag) ;
95 }
96 if ( p->boundary_array && sw_new_bdys ) {
97 int bdy ;
98 for ( bdy = 1 ; bdy <= 4 ; bdy++ )
99 {
100 if( p->type != NULL && tchar != '?' ) {
101 fprintf(fp,"num_bytes_allocated = num_bytes_allocated + (%s) * %cWORDSIZE\n",
102 array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"),
103 tchar) ;
104 }
105 if ( sw == 1 ) {
106 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",
107 structname, fname, bdy_indicator(bdy),
108 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"),
109 structname, fname, bdy_indicator(bdy),
110 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"));
111 fprintf(fp, "IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy));
112 if( p->type != NULL && (!strcmp( p->type->name , "real" )
113 || !strcmp( p->type->name , "doubleprecision") ) ) {
114 /* if a real */
115 fprintf(fp, "initial_data_value\n");
116 } else if ( !strcmp( p->type->name , "logical" ) ) {
117 fprintf(fp, ".FALSE.\n");
118 } else if ( !strcmp( p->type->name , "integer" ) ) {
119 fprintf(fp, "0\n");
120 }
121 }
122 }
123 } else {
124 if( p->type != NULL && tchar != '?' ) {
125 fprintf(fp,"num_bytes_allocated = num_bytes_allocated + (%s) * %cWORDSIZE\n",
126 array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
127 tchar) ;
128 }
129 if ( sw == 1 ) {
130 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",
131 structname, fname,
132 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"),
133 structname, fname,
134 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"));
135 fprintf(fp, "IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
136
137 if( p->type != NULL && (!strcmp( p->type->name , "real" )
138 || !strcmp( p->type->name , "doubleprecision") ) ) {
139 /* if a real */
140 fprintf(fp, "initial_data_value\n");
141 } else if ( !strcmp( p->type->name , "logical" ) ) {
142 fprintf(fp, ".FALSE.\n");
143 } else if ( !strcmp( p->type->name , "integer" ) ) {
144 fprintf(fp, "0\n");
145 }
146 }
147 }
148
149 if ( p->ntl > 1 && sw == 1 ) {
150 fprintf(fp,"ELSE\n") ;
151
152 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",
153 structname, fname, dimension_with_ones( "(",t2,p,")" ),
154 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
155
156 fprintf(fp,"ENDIF\n") ;
157 }
158
159 if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
160 ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) )
161 {
162 fprintf(fp,"ELSE\n") ;
163
164 if ( p->boundary_array && sw_new_bdys ) {
165 int bdy ;
166 for ( bdy = 1 ; bdy <= 4 ; bdy++ )
167 {
168 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",
169 structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ),
170 structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ;
171 }
172 } else {
173 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",
174 structname, fname, dimension_with_ones( "(",t2,p,")" ),
175 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
176 }
177
178 fprintf(fp,"ENDIF\n") ;
179 }
180
181 }
182 }
183 if ( p->type != NULL )
184 {
185 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
186 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
187 (!strcmp(p->type->name,"integer") ||
188 !strcmp(p->type->name,"logical") ||
189 !strcmp(p->type->name,"real") ||
190 !strcmp(p->type->name,"doubleprecision"))
191 )
192 {
193 if (!strncmp( "dyn_" , p->use , 4 ))
194 {
195 if (!strcmp( corename , p->use+4 ))
196 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
197 }
198 else
199 {
200 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
201 }
202 if ( sw == 1 ) {
203 if( !strcmp( p->type->name , "real" ) ||
204 !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */
205 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
206 structname ,
207 fname ) ;
208 } else if ( !strcmp( p->type->name , "integer" ) ) {
209 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
210 structname ,
211 fname ) ;
212 } else if ( !strcmp( p->type->name , "logical" ) ) {
213 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
214 structname ,
215 fname ) ;
216 }
217 }
218 }
219 else if ( p->type->type_type == DERIVED )
220 {
221 sprintf(x,"%s%s%%",structname,p->name ) ;
222 gen_alloc2(fp,x, corename, p->type, sw) ;
223 }
224 }
225 }
226 return(0) ;
227 }
228
229 int
230 gen_alloc_count ( char * dirname )
231 {
232 int i ;
233
234 for ( i = 0 ; i < get_num_cores() ; i++ )
235 {
236 gen_alloc_count1( dirname , get_corename_i(i) ) ;
237 }
238 return(0) ;
239 }
240
241 int
242 gen_alloc_count1 ( char * dirname , char * corename )
243 {
244 FILE * fp ;
245 char fname[NAMELEN] ;
246 char * fn = "_alloc_count.inc" ;
247
248 if ( dirname == NULL || corename == NULL ) return(1) ;
249 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
250 else { sprintf(fname,"%s%s",corename,fn) ; }
251 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
252 print_warning(fp,fname) ;
253 gen_alloc2( fp , "grid%", corename , &Domain, 0 ) ;
254 close_the_file( fp ) ;
255 return(0) ;
256 }
257
258 int
259 gen_ddt_write ( char * dirname , char * corename )
260 {
261 FILE * fp ;
262 char fname[NAMELEN] ;
263 char * fn = "_write_ddt.inc" ;
264
265 if ( dirname == NULL || corename == NULL ) return(1) ;
266 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
267 else { sprintf(fname,"%s%s",corename,fn) ; }
268 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
269 print_warning(fp,fname) ;
270 gen_ddt_write1( fp , "grid%", corename , &Domain ) ;
271 close_the_file( fp ) ;
272 return(0) ;
273 }
274
275 int
276 gen_ddt_write1 ( FILE * fp , char * structname , char * corename , node_t * node )
277 {
278 node_t * p ;
279 int tag ;
280 char post[NAMELEN] ;
281 char fname[NAMELEN] ;
282 char x[NAMELEN] ;
283
284 if ( node == NULL ) return(1) ;
285
286 for ( p = node->fields ; p != NULL ; p = p->next )
287 {
288 if ( (p->ndims > 1 && ! p->boundary_array) && ( /* any array or a boundary array and... */
289 (p->node_kind & FOURD) || /* scalar arrays or... */
290 /* if it's a core specific field and we're doing that core or... */
291 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
292 /* it is not a core specific field */
293 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
294 ))
295 {
296 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
297 else { sprintf(post,")") ; }
298 for ( tag = 1 ; tag <= p->ntl ; tag++ )
299 {
300 /* if this is a core-specific variable, prepend the name of the core to */
301 /* the variable at the driver level */
302 if (!strcmp( corename , p->use+4 ))
303 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
304 else
305 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
306
307 if ( p->node_kind & FOURD ) {
308 fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
309 } else {
310 if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
311 if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
312 }
313
314 }
315 }
316 #if 0
317 if ( p->type != NULL )
318 {
319 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
320 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
321 (!strcmp(p->type->name,"integer") ||
322 !strcmp(p->type->name,"real") ||
323 !strcmp(p->type->name,"doubleprecision"))
324 )
325 {
326 if (!strncmp( "dyn_" , p->use , 4 ))
327 {
328 if (!strcmp( corename , p->use+4 ))
329 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
330 }
331 else
332 {
333 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
334 }
335 fprintf(fp, "write(iunit)%s%s\n",structname,fname) ;
336 }
337 }
338 #endif
339 }
340 return(0) ;
341 }
342
343 int
344 gen_dealloc ( char * dirname )
345 {
346 int i ;
347
348 for ( i = 0 ; i < get_num_cores() ; i++ )
349 {
350 gen_dealloc1( dirname , get_corename_i(i) ) ;
351 }
352 return(0) ;
353 }
354
355 int
356 gen_dealloc1 ( char * dirname , char * corename )
357 {
358 FILE * fp ;
359 char fname[NAMELEN] ;
360 char * fn = "_deallocs.inc" ;
361
362 if ( dirname == NULL || corename == NULL ) return(1) ;
363 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
364 else { sprintf(fname,"%s%s",corename,fn) ; }
365 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
366 print_warning(fp,fname) ;
367 gen_dealloc2( fp , "grid%", corename , &Domain ) ;
368 close_the_file( fp ) ;
369 return(0) ;
370 }
371
372 int
373 gen_dealloc2 ( FILE * fp , char * structname , char * corename , node_t * node )
374 {
375 node_t * p ;
376 int tag ;
377 char post[NAMELEN] ;
378 char fname[NAMELEN] ;
379 char x[NAMELEN] ;
380
381 if ( node == NULL ) return(1) ;
382
383 for ( p = node->fields ; p != NULL ; p = p->next )
384 {
385 if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */
386 (p->node_kind & FOURD) || /* scalar arrays or... */
387 /* if it's a core specific field and we're doing that core or... */
388 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
389 /* it is not a core specific field */
390 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
391 ))
392 {
393 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
394 else { sprintf(post,")") ; }
395 for ( tag = 1 ; tag <= p->ntl ; tag++ )
396 {
397 /* if this is a core-specific variable, prepend the name of the core to */
398 /* the variable at the driver level */
399 if (!strcmp( corename , p->use+4 ))
400 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
401 else
402 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
403
404 if ( p->boundary && sw_new_bdys ) {
405 { int bdy ;
406 for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
407 fprintf(fp,
408 "IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
409 fprintf(fp,
410 " 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",
411 structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ;
412 fprintf(fp,
413 " NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ;
414 fprintf(fp,
415 "ENDIF\n" ) ;
416 }
417 }
418 } else {
419 fprintf(fp,
420 "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
421 fprintf(fp,
422 " 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",
423 structname, fname, structname, fname ) ;
424 fprintf(fp,
425 " NULLIFY(%s%s)\n",structname, fname ) ;
426 fprintf(fp,
427 "ENDIF\n" ) ;
428 }
429
430
431 }
432 }
433 if ( p->type != NULL )
434 {
435 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
436 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
437 (!strcmp(p->type->name,"integer") ||
438 !strcmp(p->type->name,"real") ||
439 !strcmp(p->type->name,"doubleprecision"))
440 )
441 {
442 }
443 else if ( p->type->type_type == DERIVED )
444 {
445 sprintf(x,"%s%s%%",structname,p->name ) ;
446 gen_dealloc2(fp,x, corename, p->type) ;
447 }
448 }
449 }
450 return(0) ;
451 }