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 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",
86 structname, fname,
87 dimension_with_ranges( "", "(", t2, p, post, "model_config_rec%"),
88 structname, fname,
89 dimension_with_ranges( "", "(", t2, p, post, "model_config_rec%"));
90
91 fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
92 if( p->type != NULL && (!strcmp( p->type->name , "real" )
93 || !strcmp( p->type->name , "doubleprecision") ) ) {
94 /* if a real */
95 fprintf(fp, "initial_data_value\n");
96 } else if ( !strcmp( p->type->name , "logical" ) ) {
97 fprintf(fp, ".FALSE.\n");
98 } else if ( !strcmp( p->type->name , "integer" ) ) {
99 fprintf(fp, "0\n");
100 }
101 if ( p->ntl > 1 ) {
102 fprintf(fp,"ELSE\n") ;
103
104 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",
105 structname, fname, dimension_with_ones( "(",t2,p,")" ),
106 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
107
108
109
110 fprintf(fp,"ENDIF\n") ;
111 }
112 if ( ! ( p->node_kind & FOURD ) &&
113 ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) )
114 {
115 fprintf(fp,"ELSE\n") ;
116 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",
117 structname, fname, dimension_with_ones( "(",t2,p,")" ),
118 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
119 fprintf(fp,"ENDIF\n") ;
120 }
121
122 }
123 }
124 if ( p->type != NULL )
125 {
126 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
127 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
128 (!strcmp(p->type->name,"integer") ||
129 !strcmp(p->type->name,"logical") ||
130 !strcmp(p->type->name,"real") ||
131 !strcmp(p->type->name,"doubleprecision"))
132 )
133 {
134 if (!strncmp( "dyn_" , p->use , 4 ))
135 {
136 if ( (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) )
137 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
138 }
139 else
140 {
141 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
142 }
143 if( !strcmp( p->type->name , "real" ) ||
144 !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */
145 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
146 structname ,
147 fname ) ;
148 } else if ( !strcmp( p->type->name , "integer" ) ) {
149 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
150 structname ,
151 fname ) ;
152 } else if ( !strcmp( p->type->name , "logical" ) ) {
153 fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
154 structname ,
155 fname ) ;
156 }
157 }
158 else if ( p->type->type_type == DERIVED )
159 {
160 sprintf(x,"%s%s%%",structname,p->name ) ;
161 gen_alloc2(fp,x, corename, p->type) ;
162 }
163 }
164 }
165 return(0) ;
166 }
167
168 int
169 gen_ddt_write ( char * dirname , char * corename )
170 {
171 FILE * fp ;
172 char fname[NAMELEN] ;
173 char * fn = "_write_ddt.inc" ;
174
175 if ( dirname == NULL || corename == NULL ) return(1) ;
176 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
177 else { sprintf(fname,"%s%s",corename,fn) ; }
178 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
179 print_warning(fp,fname) ;
180 gen_ddt_write1( fp , "grid%", corename , &Domain ) ;
181 close_the_file( fp ) ;
182 return(0) ;
183 }
184
185 int
186 gen_ddt_write1 ( FILE * fp , char * structname , char * corename , node_t * node )
187 {
188 node_t * p ;
189 int tag ;
190 char post[NAMELEN] ;
191 char fname[NAMELEN] ;
192 char x[NAMELEN] ;
193
194 if ( node == NULL ) return(1) ;
195
196 for ( p = node->fields ; p != NULL ; p = p->next )
197 {
198 if ( (p->ndims > 1 && ! p->boundary_array) && ( /* any array or a boundary array and... */
199 (p->node_kind & FOURD) || /* scalar arrays or... */
200 /* if it's a core specific field and we're doing that core or... */
201 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
202 /* it is not a core specific field */
203 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
204 ))
205 {
206 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
207 else { sprintf(post,")") ; }
208 for ( tag = 1 ; tag <= p->ntl ; tag++ )
209 {
210 /* if this is a core-specific variable, prepend the name of the core to */
211 /* the variable at the driver level */
212 if ( (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) )
213
214 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
215 else
216 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
217
218 if ( p->node_kind & FOURD ) {
219 fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
220 } else {
221 if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
222 if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
223 }
224
225 }
226 }
227 #if 0
228 if ( p->type != NULL )
229 {
230 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
231 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
232 (!strcmp(p->type->name,"integer") ||
233 !strcmp(p->type->name,"real") ||
234 !strcmp(p->type->name,"doubleprecision"))
235 )
236 {
237 if (!strncmp( "dyn_" , p->use , 4 ))
238 {
239 if ( (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) )
240 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
241 }
242 else
243 {
244 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
245 }
246 fprintf(fp, "write(iunit)%s%s\n",structname,fname) ;
247 }
248 }
249 #endif
250 }
251 return(0) ;
252 }
253
254 int
255 gen_dealloc ( char * dirname )
256 {
257 int i ;
258
259 for ( i = 0 ; i < get_num_cores() ; i++ )
260 {
261 gen_dealloc1( dirname , get_corename_i(i) ) ;
262 }
263 return(0) ;
264 }
265
266 int
267 gen_dealloc1 ( char * dirname , char * corename )
268 {
269 FILE * fp ;
270 char fname[NAMELEN] ;
271 char * fn = "_deallocs.inc" ;
272
273 if ( dirname == NULL || corename == NULL ) return(1) ;
274 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
275 else { sprintf(fname,"%s%s",corename,fn) ; }
276 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
277 print_warning(fp,fname) ;
278 gen_dealloc2( fp , "grid%", corename , &Domain ) ;
279 close_the_file( fp ) ;
280 return(0) ;
281 }
282
283 int
284 gen_dealloc2 ( FILE * fp , char * structname , char * corename , node_t * node )
285 {
286 node_t * p ;
287 int tag ;
288 char post[NAMELEN] ;
289 char fname[NAMELEN] ;
290 char x[NAMELEN] ;
291
292 if ( node == NULL ) return(1) ;
293
294 for ( p = node->fields ; p != NULL ; p = p->next )
295 {
296 if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */
297 (p->node_kind & FOURD) || /* scalar arrays or... */
298 /* if it's a core specific field and we're doing that core or... */
299 (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
300 /* it is not a core specific field */
301 (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
302 ))
303 {
304 if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
305 else { sprintf(post,")") ; }
306 for ( tag = 1 ; tag <= p->ntl ; tag++ )
307 {
308 /* if this is a core-specific variable, prepend the name of the core to */
309 /* the variable at the driver level */
310 if ( (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) )
311 sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
312 else
313 strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
314
315 fprintf(fp,
316 "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
317 fprintf(fp,
318 " 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",
319 structname, fname, structname, fname ) ;
320 fprintf(fp,
321 " NULLIFY(%s%s)\n",structname, fname ) ;
322 fprintf(fp,
323 "ENDIF\n" ) ;
324
325
326 }
327 }
328 if ( p->type != NULL )
329 {
330 if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
331 ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
332 (!strcmp(p->type->name,"integer") ||
333 !strcmp(p->type->name,"real") ||
334 !strcmp(p->type->name,"doubleprecision"))
335 )
336 {
337 }
338 else if ( p->type->type_type == DERIVED )
339 {
340 sprintf(x,"%s%s%%",structname,p->name ) ;
341 gen_dealloc2(fp,x, corename, p->type) ;
342 }
343 }
344 }
345 return(0) ;
346 }