?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
wrf svn trunk commit r4103
[wrffire.git] / wrfv2_fire / tools / gen_allocs.c
blob07795b5778c5d1223c0d9a6b3bc17799f945ad9a
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <string.h>
4 #ifndef _WIN32
5 # include <strings.h>
6 #endif
7
8 #include "protos.h"
9 #include "registry.h"
10 #include "data.h"
11 #include "sym.h"
12
13 int
14 gen_alloc ( char * dirname )
15 {
16 gen_alloc1( dirname ) ;
17 gen_ddt_write( dirname ) ;
18 return(0) ;
19 }
20
21 int
22 get_count_for_alloc( node_t *node , int *numguys, int *stats) ; /* forward */
23
24 int
25 gen_alloc1 ( char * dirname )
26 {
27 FILE * fp ;
28 char fname[NAMELEN] ;
29 char * fn = "allocs.inc" ;
30 int startpiece, fraction, iguy, numguys ;
31 int stats[4] ;
32 #define FRAC 8
33
34 if ( dirname == NULL ) return(1) ;
35 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
36 else { sprintf(fname,"%s",fn) ; }
37 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
38 print_warning(fp,fname) ;
39 startpiece = 0 ;
40 fraction = 0 ;
41 numguys = 0 ;
42 iguy = -1 ;
43 stats[0] = 0 ; stats[1] = 0 ; stats[2] = 0 ; stats[3] = 0 ;
44 get_count_for_alloc( &Domain, &numguys , stats) ; /* howmany deez guys? */
45 fprintf(stderr,"Registry INFO variable counts: 0d %d 1d %d 2d %d 3d %d\n",stats[0],stats[1],stats[2],stats[3]) ;
46 fprintf(fp,"#if 1\n") ;
47 gen_alloc2( fp , "grid%", &Domain, &startpiece , &iguy, &fraction, numguys, FRAC, 1 ) ;
48 fprintf(fp,"#endif\n") ;
49 close_the_file( fp ) ;
50 return(0) ;
51 }
52
53 int
54 get_count_for_alloc( node_t *node , int *numguys, int * stats )
55 {
56 node_t * p ;
57 for ( p = node->fields ; p != NULL ; p = p->next ) {
58 if ( p->type != NULL && p->type->type_type == DERIVED ) {
59 get_count_for_alloc( p->type , numguys, stats ) ;
60 } else if (p->ndims >= 0) {
61 (*numguys)++ ;
62 if ( p->ndims == 0 ) {
63 stats[p->ndims]++ ;
64 } else if ( p->ndims == 1 ) {
65 stats[p->ndims]++ ;
66 } else if ( p->ndims == 2 ) {
67 stats[p->ndims]++ ;
68 } else if ( p->ndims == 3 ) {
69 stats[p->ndims]++ ;
70 }
71 }
72 }
73 }
74
75 int
76 nolistthese( char * ) ;
77
78 int
79 gen_alloc2 ( FILE * fp , char * structname , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ) /* 1 = allocate, 2 = just count */
80 {
81 node_t * p ;
82 int tag ;
83 char post[NAMELEN], post_for_count[NAMELEN] ;
84 char fname[NAMELEN], dname[NAMELEN], dname_tmp[NAMELEN] ;
85 char x[NAMELEN] ;
86 char dimname[3][NAMELEN] ;
87 char tchar ;
88 unsigned int *io_mask ;
89 int nd ;
90 int restart ;
91
92 if ( node == NULL ) return(1) ;
93
94 for ( p = node->fields ; p != NULL ; p = p->next )
95 {
96 (*iguy)++ ;
97
98 if ( (*iguy % ((numguys+1)/frac+1)) == 0 ) {
99 fprintf(fp,"#endif\n") ;
100 fprintf(fp,"#if (NNN == %d)\n",(*j)++) ;
101 }
102
103 nd = p->ndims + ((p->node_kind & FOURD)?1:0) ;
104
105 /* construct data name -- maybe same as vname if dname not spec'd */
106 if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") || p->dname[0] == ' ' )
107 { strcpy(dname_tmp,p->name) ; }
108 else { strcpy(dname_tmp,p->dname) ; }
109 make_upper_case(dname_tmp) ;
110
111 /*
112 Generate error if input or output for two state variables would be generated with the same dataname
113
114 example wrong:
115 misc tg "SOILTB" -> gen_tg,SOILTB
116 misc soiltb "SOILTB" -> gen_soiltb,SOILTB
117
118 */
119 if ( tag == 1 )
120 {
121 char dname_symbol[128] ;
122 sym_nodeptr sym_node ;
123
124 sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ;
125 /* check and see if it is in the symbol table already */
126
127 if ((sym_node = sym_get( dname_symbol )) == NULL ) {
128 /* add it */
129 sym_node = sym_add ( dname_symbol ) ;
130 strcpy( sym_node->internal_name , p->name ) ;
131 } else {
132 fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s -- %s\n",
133 dname_tmp,p->name,p->dname ) ;
134 }
135 }
136 /* end July 2004 */
137
138
139 if ( p->ndims == 0 ) {
140 if ( p->type->name[0] != 'c' && p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) ) {
141 for ( tag = 1 ; tag <= p->ntl ; tag++ )
142 {
143 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
144 if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
145 else strcpy(dname,dname_tmp) ;
146
147 /* fprintf(fp," IF (.NOT.inter_domain) THEN\n") ; */
148 fprintf(fp," IF (.NOT.grid%%is_intermediate) THEN\n") ;
149 fprintf(fp," ALLOCATE( grid%%tail_statevars%%next )\n") ;
150 fprintf(fp," grid%%tail_statevars => grid%%tail_statevars%%next\n") ;
151 fprintf(fp," NULLIFY( grid%%tail_statevars%%next )\n" ) ;
152 fprintf(fp," grid%%tail_statevars%%VarName = '%s'\n",fname ) ;
153 fprintf(fp," grid%%tail_statevars%%DataName = '%s'\n",dname ) ;
154 fprintf(fp," grid%%tail_statevars%%Type = '%c'\n",p->type->name[0]) ;
155 fprintf(fp," grid%%tail_statevars%%Ntl = %d\n",p->ntl<2?0:tag+p->ntl*100 ) ; /* if single tl, then 0, else tl itself */
156 fprintf(fp," grid%%tail_statevars%%Restart = %s\n", (p->restart)?".TRUE.":".FALSE." ) ;
157 fprintf(fp," grid%%tail_statevars%%Ndim = %d\n",p->ndims ) ;
158 fprintf(fp," grid%%tail_statevars%%scalar_array = .FALSE. \n" ) ;
159 fprintf(fp," grid%%tail_statevars%%%cfield_%1dd => %s%s\n",p->type->name[0],p->ndims, structname, fname ) ;
160 io_mask = p->io_mask ;
161 if ( io_mask != NULL ) {
162 int i ;
163 for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
164 fprintf(fp," grid%%tail_statevars%%streams(%d) = %d ! %08x \n", i+1, io_mask[i], io_mask[i] ) ;
165 }
166 }
167 fprintf(fp," ENDIF\n") ;
168 }
169 }
170 if ( sw == 1 ) {
171 for ( tag = 1 ; tag <= p->ntl ; tag++ )
172 {
173 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
174 if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
175 else strcpy(dname,dname_tmp) ;
176 if( !strcmp( p->type->name , "real" ) ||
177 !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */
178 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
179 structname ,
180 fname ) ;
181 } else if ( !strcmp( p->type->name , "integer" ) ) {
182 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
183 structname ,
184 fname ) ;
185 } else if ( !strcmp( p->type->name , "logical" ) ) {
186 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
187 structname ,
188 fname ) ;
189 }
190 }
191 }
192 }
193 if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */
194 (p->node_kind & FIELD) || /* scalar arrays */
195 (p->node_kind & FOURD) ) /* scalar arrays */
196 )
197 {
198 if ( p->type != NULL ) {
199 tchar = '?' ;
200 if ( !strcmp( p->type->name , "real" ) ) { tchar = 'R' ; }
201 else if ( !strcmp( p->type->name , "doubleprecision" ) ) { tchar = 'D' ; }
202 else if ( !strcmp( p->type->name , "logical" ) ) { tchar = 'L' ; }
203 else if ( !strcmp( p->type->name , "integer" ) ) { tchar = 'I' ; }
204 else { fprintf(stderr,"WARNING: what is the type for %s ?\n", p->name) ; }
205 }
206 if ( p->node_kind & FOURD ) { sprintf(post, ",num_%s)",field_name(t4,p,0)) ;
207 sprintf(post_for_count, "*num_%s)",field_name(t4,p,0)) ; }
208 else { sprintf(post, ")" ) ;
209 sprintf(post_for_count, ")" ) ; }
210 for ( tag = 1 ; tag <= p->ntl ; tag++ )
211 {
212 if ( !strcmp ( p->use , "_4d_bdy_array_") ) {
213 strcpy(fname,p->name) ;
214 } else {
215 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
216 }
217
218 /* check for errors in memory allocation */
219
220 if ( ! p->boundary_array ) { fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ; }
221 else { fprintf(fp,"IF(.TRUE.") ; }
222
223 if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
224 ! ( p->nest_mask & INTERP_DOWN || p->nest_mask & FORCE_DOWN || p->nest_mask & INTERP_UP || p->nest_mask & SMOOTH_UP ) )
225 {
226 /* fprintf(fp,".AND.(.NOT.inter_domain)",tag) ; */
227 fprintf(fp,".AND.(.NOT.grid%%is_intermediate)",tag) ;
228 }
229 if ( p->ntl > 1 && sw == 1 ) {
230 fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ;
231 }
232 fprintf(fp,")THEN\n") ;
233 if ( p->boundary_array && sw_new_bdys ) {
234 int bdy ;
235 for ( bdy = 1 ; bdy <= 4 ; bdy++ )
236 {
237 if( p->type != NULL && tchar != '?' ) {
238 fprintf(fp," num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
239 array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"),
240 tchar) ;
241 }
242 if ( sw == 1 ) {
243 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",
244 structname, fname, bdy_indicator(bdy),
245 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"),
246 structname, fname, bdy_indicator(bdy),
247 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"));
248 fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy));
249 if( p->type != NULL && (!strcmp( p->type->name , "real" )
250 || !strcmp( p->type->name , "doubleprecision") ) ) {
251 /* if a real */
252 fprintf(fp, "initial_data_value\n");
253 } else if ( !strcmp( p->type->name , "logical" ) ) {
254 fprintf(fp, ".FALSE.\n");
255 } else if ( !strcmp( p->type->name , "integer" ) ) {
256 fprintf(fp, "0\n");
257 }
258 }
259 }
260 } else {
261 if( p->type != NULL && tchar != '?' ) {
262 fprintf(fp," num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
263 array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
264 tchar) ;
265 }
266 if ( sw == 1 ) {
267 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",
268 structname, fname,
269 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"),
270 structname, fname,
271 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"));
272 fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
273
274 if( p->type != NULL && (!strcmp( p->type->name , "real" )
275 || !strcmp( p->type->name , "doubleprecision") ) ) {
276 /* if a real */
277 fprintf(fp, "initial_data_value\n");
278 } else if ( !strcmp( p->type->name , "logical" ) ) {
279 fprintf(fp, ".FALSE.\n");
280 } else if ( !strcmp( p->type->name , "integer" ) ) {
281 fprintf(fp, "0\n");
282 }
283
284 if ( p->type->name[0] == 'l' && p->ndims >= 3 ) {
285 fprintf(stderr,"ADVISORY: %1dd logical array %s is allowed but cannot be input or output\n",
286 p->ndims, p->name ) ;
287
288 }
289
290 if ( p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) &&
291 ! ( p->type->name[0] == 'l' && p->ndims >= 3 ) ) /* dont list logical arrays larger than 2d */
292 {
293 char memord[NAMELEN], stagstr[NAMELEN] ;
294
295
296 strcpy(stagstr, "") ;
297 if ( p->node_kind & FOURD ) {
298 set_mem_order( p->members, memord , NAMELEN) ;
299 if ( p->members->stag_x ) strcat(stagstr, "X") ;
300 if ( p->members->stag_y ) strcat(stagstr, "Y") ;
301 if ( p->members->stag_z ) strcat(stagstr, "Z") ;
302 } else {
303 set_mem_order( p, memord , NAMELEN) ;
304 if ( p->stag_x ) strcat(stagstr, "X") ;
305 if ( p->stag_y ) strcat(stagstr, "Y") ;
306 if ( p->stag_z ) strcat(stagstr, "Z") ;
307 }
308 memord[3] = '\0' ; /* snip off any extra dimensions */
309
310 if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
311 else strcpy(dname,dname_tmp) ;
312
313 fprintf(fp," IF (.NOT.grid%%is_intermediate) THEN\n") ; /*{*/
314 fprintf(fp," ALLOCATE( grid%%tail_statevars%%next )\n" ) ;
315 fprintf(fp," grid%%tail_statevars => grid%%tail_statevars%%next\n") ;
316 fprintf(fp," NULLIFY( grid%%tail_statevars%%next )\n") ;
317 fprintf(fp," grid%%tail_statevars%%VarName = '%s'\n", fname) ;
318 fprintf(fp," grid%%tail_statevars%%DataName = '%s'\n", dname) ;
319 fprintf(fp," grid%%tail_statevars%%Type = '%c'\n", p->type->name[0]) ;
320 fprintf(fp," grid%%tail_statevars%%MemoryOrder = '%s'\n", memord) ;
321 fprintf(fp," grid%%tail_statevars%%Stagger = '%s'\n", stagstr) ;
322 /* in next line for Ntl, if single tl, then zero, otherwise tl itself */
323 fprintf(fp," grid%%tail_statevars%%Ntl = %d\n", p->ntl<2?0:tag+p->ntl*100 ) ;
324 fprintf(fp," grid%%tail_statevars%%Ndim = %d\n", nd ) ;
325 restart = 0 ;
326 if ( p->node_kind & FOURD ) {
327 node_t *q ;
328 for ( q = p->members ; q->next != NULL ; q = q->next ) { /* use the last one */
329 if ( q != NULL ) {
330 restart = q->restart ;
331 }
332 }
333 } else {
334 restart = p->restart ;
335 }
336 fprintf(fp," grid%%tail_statevars%%Restart = %s\n", (restart)?".TRUE.":".FALSE." ) ;
337 fprintf(fp," grid%%tail_statevars%%scalar_array = %s\n", (p->node_kind & FOURD)?".TRUE.":".FALSE.") ;
338 fprintf(fp," grid%%tail_statevars%%%cfield_%1dd => %s%s\n", p->type->name[0],nd, structname, fname ) ;
339 if ( p->node_kind & FOURD ) {
340 fprintf(fp," grid%%tail_statevars%%num_table => %s_num_table\n", p->name ) ;
341 fprintf(fp," grid%%tail_statevars%%index_table => %s_index_table\n", p->name ) ;
342 fprintf(fp," grid%%tail_statevars%%boundary_table => %s_boundary_table\n", p->name ) ;
343 fprintf(fp," grid%%tail_statevars%%dname_table => %s_dname_table\n", p->name ) ;
344 fprintf(fp," grid%%tail_statevars%%desc_table => %s_desc_table\n", p->name ) ;
345 fprintf(fp," grid%%tail_statevars%%units_table => %s_units_table\n", p->name ) ;
346 }
347
348 if ( p->node_kind & FOURD ) {
349 node_t *q ;
350 io_mask = NULL ;
351 for ( q = p->members ; q->next != NULL ; q = q->next ) { /* use the last one */
352 if ( q != NULL ) {
353 io_mask = q->io_mask ;
354 }
355 }
356 } else {
357 io_mask = p->io_mask ;
358 }
359
360 if ( io_mask != NULL ) {
361 int i ;
362 for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
363 fprintf(fp," grid%%tail_statevars%%streams(%d) = %d ! %08x \n", i+1, io_mask[i], io_mask[i] ) ;
364 }
365 }
366
367 {
368 char ddim[3][2][NAMELEN] ;
369 char mdim[3][2][NAMELEN] ;
370 char pdim[3][2][NAMELEN] ;
371
372 set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */
373
374 fprintf(fp," grid%%tail_statevars%%sd1 = %s\n", ddim[0][0] ) ;
375 fprintf(fp," grid%%tail_statevars%%ed1 = %s\n", ddim[0][1] ) ;
376 fprintf(fp," grid%%tail_statevars%%sd2 = %s\n", ddim[1][0] ) ;
377 fprintf(fp," grid%%tail_statevars%%ed2 = %s\n", ddim[1][1] ) ;
378 fprintf(fp," grid%%tail_statevars%%sd3 = %s\n", ddim[2][0] ) ;
379 fprintf(fp," grid%%tail_statevars%%ed3 = %s\n", ddim[2][1] ) ;
380 fprintf(fp," grid%%tail_statevars%%sm1 = %s\n", mdim[0][0] ) ;
381 fprintf(fp," grid%%tail_statevars%%em1 = %s\n", mdim[0][1] ) ;
382 fprintf(fp," grid%%tail_statevars%%sm2 = %s\n", mdim[1][0] ) ;
383 fprintf(fp," grid%%tail_statevars%%em2 = %s\n", mdim[1][1] ) ;
384 fprintf(fp," grid%%tail_statevars%%sm3 = %s\n", mdim[2][0] ) ;
385 fprintf(fp," grid%%tail_statevars%%em3 = %s\n", mdim[2][1] ) ;
386 fprintf(fp," grid%%tail_statevars%%sp1 = %s\n", pdim[0][0] ) ;
387 fprintf(fp," grid%%tail_statevars%%ep1 = %s\n", pdim[0][1] ) ;
388 fprintf(fp," grid%%tail_statevars%%sp2 = %s\n", pdim[1][0] ) ;
389 fprintf(fp," grid%%tail_statevars%%ep2 = %s\n", pdim[1][1] ) ;
390 fprintf(fp," grid%%tail_statevars%%sp3 = %s\n", pdim[2][0] ) ;
391 fprintf(fp," grid%%tail_statevars%%ep3 = %s\n", pdim[2][1] ) ;
392
393 }
394 {
395 int i ;
396 node_t * dimnode ;
397 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
398 for ( i = 0 ; i < 3 ; i++ )
399 {
400 if (( dimnode = p->dims[i]) != NULL )
401 {
402 switch ( dimnode->coord_axis )
403 {
404 case (COORD_X) :
405 if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
406 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
407 else if ( p->dims[i]->subgrid )
408 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
409 else
410 { strcpy( dimname[i], dimnode->dim_data_name) ; }
411 break ;
412 case (COORD_Y) :
413 if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
414 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
415 else if ( p->dims[i]->subgrid )
416 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
417 else
418 { strcpy( dimname[i], dimnode->dim_data_name) ; }
419 break ;
420 case (COORD_Z) :
421 if ( p->stag_z )
422 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
423 else if ( p->dims[i]->subgrid )
424 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
425 else
426 { strcpy( dimname[i], dimnode->dim_data_name) ; }
427 break ;
428 }
429 }
430 }
431 fprintf(fp," grid%%tail_statevars%%dimname1 = '%s'\n", dimname[0] ) ;
432 fprintf(fp," grid%%tail_statevars%%dimname2 = '%s'\n", dimname[1] ) ;
433 fprintf(fp," grid%%tail_statevars%%dimname3 = '%s'\n", dimname[2] ) ;
434 }
435 fprintf(fp," ENDIF\n") ; /*}*/
436 }
437 }
438 }
439
440 fprintf(fp,"ELSE\n") ;
441
442 if ( p->boundary_array && sw_new_bdys ) {
443 int bdy ;
444 for ( bdy = 1 ; bdy <= 4 ; bdy++ )
445 {
446 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",
447 structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ),
448 structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ;
449 }
450 } else {
451 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",
452 structname, fname, dimension_with_ones( "(",t2,p,")" ),
453 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
454
455 }
456
457 fprintf(fp,"ENDIF\n") ; /* end of in_use conditional */
458
459 }
460 }
461 if ( p->type != NULL )
462 {
463 if ( p->type->type_type == DERIVED )
464 {
465 sprintf(x,"%s%s%%",structname,p->name ) ;
466 gen_alloc2(fp,x, p->type, j, iguy, fraction, numguys, 1, sw) ;
467 }
468 }
469 } /* fraction loop */
470 return(0) ;
471 }
472
473 #if 0
474 int
475 gen_alloc_count ( char * dirname )
476 {
477 gen_alloc_count1( dirname ) ;
478 return(0) ;
479 }
480
481 int
482 gen_alloc_count1 ( char * dirname )
483 {
484 FILE * fp ;
485 char fname[NAMELEN] ;
486 char * fn = "alloc_count.inc" ;
487
488 if ( dirname == NULL ) return(1) ;
489 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
490 else { sprintf(fname,"%s",fn) ; }
491 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
492 print_warning(fp,fname) ;
493 gen_alloc2( fp , "grid%", &Domain, 0 ) ;
494 close_the_file( fp ) ;
495 return(0) ;
496 }
497 #endif
498
499 int
500 gen_ddt_write ( char * dirname )
501 {
502 FILE * fp ;
503 char fname[NAMELEN] ;
504 char * fn = "write_ddt.inc" ;
505
506 if ( dirname == NULL ) return(1) ;
507 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
508 else { sprintf(fname,"%s",fn) ; }
509 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
510 print_warning(fp,fname) ;
511 gen_ddt_write1( fp , "grid%", &Domain ) ;
512 close_the_file( fp ) ;
513 return(0) ;
514 }
515
516 int
517 gen_ddt_write1 ( FILE * fp , char * structname , node_t * node )
518 {
519 node_t * p ;
520 int tag ;
521 char post[NAMELEN] ;
522 char fname[NAMELEN] ;
523 char x[NAMELEN] ;
524
525 if ( node == NULL ) return(1) ;
526
527 for ( p = node->fields ; p != NULL ; p = p->next )
528 {
529 if ( (p->ndims > 1 && ! p->boundary_array) && ( /* any array or a boundary array and... */
530 (p->node_kind & FIELD) || /* scalar arrays or... */
531 (p->node_kind & FOURD) ) /* scalar arrays or... */
532 )
533 {
534 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
535 else { sprintf(post,")") ; }
536 for ( tag = 1 ; tag <= p->ntl ; tag++ )
537 {
538 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
539
540 if ( p->node_kind & FOURD ) {
541 fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
542 } else {
543 if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
544 if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
545 }
546
547 }
548 }
549 }
550 return(0) ;
551 }
552
553 int
554 gen_dealloc ( char * dirname )
555 {
556 gen_dealloc1( dirname ) ;
557 return(0) ;
558 }
559
560 int
561 gen_dealloc1 ( char * dirname )
562 {
563 FILE * fp ;
564 char fname[NAMELEN] ;
565 char * fn = "deallocs.inc" ;
566
567 if ( dirname == NULL ) return(1) ;
568 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
569 else { sprintf(fname,"%s",fn) ; }
570 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
571 print_warning(fp,fname) ;
572 gen_dealloc2( fp , "grid%", &Domain ) ;
573 close_the_file( fp ) ;
574 return(0) ;
575 }
576
577 int
578 gen_dealloc2 ( FILE * fp , char * structname , node_t * node )
579 {
580 node_t * p ;
581 int tag ;
582 char post[NAMELEN] ;
583 char fname[NAMELEN] ;
584 char x[NAMELEN] ;
585
586 if ( node == NULL ) return(1) ;
587
588 for ( p = node->fields ; p != NULL ; p = p->next )
589 {
590 if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */
591 (p->node_kind & FIELD) || /* scalar arrays or */
592 (p->node_kind & FOURD) ) /* scalar arrays or */
593 )
594 {
595 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
596 else { sprintf(post,")") ; }
597 for ( tag = 1 ; tag <= p->ntl ; tag++ )
598 {
599 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
600
601 if ( p->boundary && sw_new_bdys ) {
602 { int bdy ;
603 for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
604 fprintf(fp,
605 "IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
606 fprintf(fp,
607 " DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s%s. ')\n endif\n",
608 structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ;
609 fprintf(fp,
610 " NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ;
611 fprintf(fp,
612 "ENDIF\n" ) ;
613 }
614 }
615 } else {
616 fprintf(fp,
617 "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
618 fprintf(fp,
619 " DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s. ')\n endif\n",
620 structname, fname, structname, fname ) ;
621 fprintf(fp,
622 " NULLIFY(%s%s)\n",structname, fname ) ;
623 fprintf(fp,
624 "ENDIF\n" ) ;
625 }
626
627
628 }
629 }
630 if ( p->type != NULL )
631 {
632 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
633 (!strcmp(p->type->name,"integer") ||
634 !strcmp(p->type->name,"real") ||
635 !strcmp(p->type->name,"doubleprecision"))
636 )
637 {
638 }
639 else if ( p->type->type_type == DERIVED )
640 {
641 sprintf(x,"%s%s%%",structname,p->name ) ;
642 gen_dealloc2(fp,x, p->type) ;
643 }
644 }
645 }
646 return(0) ;
647 }
648
649 int
650 nolistthese( char * name )
651 {
652 return(
653 !strncmp(name,"auxhist",7)
654 || !strncmp(name,"auxinput",8)
655 || !strncmp(name,"oid",3)
656 ) ;
657 }
A coupled weather-fire forecasting model built on top of Weather Research and Forecasting (WRF).