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