source: trunk/WRF.COMMON/WRFV2/tools/gen_allocs.c @ 2981

Last change on this file since 2981 was 11, checked in by aslmd, 15 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 12.3 KB
Line 
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
10int
11gen_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
23int
24gen_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
40int
41gen_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 (      !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 (!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
168int
169gen_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
185int
186gen_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 (!strcmp( corename , p->use+4 ))
213          sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
214        else
215          strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
216
217       if ( p->node_kind & FOURD ) {
218         fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
219       } else {
220         if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
221         if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
222       }
223
224      }
225    }
226#if 0
227    if ( p->type != NULL )
228    {
229      if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
230               ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
231               (!strcmp(p->type->name,"integer") ||
232                        !strcmp(p->type->name,"real") ||
233                        !strcmp(p->type->name,"doubleprecision"))
234              )
235      {
236          if (!strncmp( "dyn_" , p->use , 4 ))
237          {
238            if (!strcmp( corename , p->use+4 ))
239              sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
240          }
241          else
242          {
243            strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
244          }
245          fprintf(fp, "write(iunit)%s%s\n",structname,fname) ;
246      }
247    }
248#endif
249  }
250  return(0) ;
251}
252
253int
254gen_dealloc ( char * dirname )
255{
256  int i ;
257 
258  for ( i = 0 ; i < get_num_cores() ; i++ )
259  {
260    gen_dealloc1( dirname , get_corename_i(i) ) ; 
261  }
262  return(0) ;
263}
264
265int
266gen_dealloc1 ( char * dirname , char * corename )
267{
268  FILE * fp ;
269  char  fname[NAMELEN] ;
270  char * fn = "_deallocs.inc" ;
271
272  if ( dirname == NULL || corename == NULL ) return(1) ;
273  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; }
274  else                       { sprintf(fname,"%s%s",corename,fn) ; }
275  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
276  print_warning(fp,fname) ;
277  gen_dealloc2( fp , "grid%", corename , &Domain ) ;
278  close_the_file( fp ) ;
279  return(0) ;
280}
281
282int
283gen_dealloc2 ( FILE * fp , char * structname , char * corename , node_t * node )
284{
285  node_t * p ;
286  int tag ;
287  char post[NAMELEN] ;
288  char fname[NAMELEN] ;
289  char x[NAMELEN] ;
290
291  if ( node == NULL ) return(1) ;
292
293  for ( p = node->fields ; p != NULL ; p = p->next )
294  {
295    if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
296          (p->node_kind & FOURD) ||                /* scalar arrays or...                    */
297                                                   /* if it's a core specific field and we're doing that core or...  */
298          (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) ||
299                                                   /* it is not a core specific field        */
300          (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4)))
301                         ))
302    {
303      if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
304      else                        { sprintf(post,")") ; }
305      for ( tag = 1 ; tag <= p->ntl ; tag++ )
306      {
307        /* if this is a core-specific variable, prepend the name of the core to   */
308        /* the variable at the driver level                                       */
309        if (!strcmp( corename , p->use+4 ))
310          sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ;
311        else
312          strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
313
314        fprintf(fp,
315"IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
316        fprintf(fp, 
317"  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",
318structname, fname, structname, fname ) ;
319        fprintf(fp,
320"  NULLIFY(%s%s)\n",structname, fname ) ;
321        fprintf(fp,
322"ENDIF\n" ) ;
323
324
325      }
326    }
327    if ( p->type != NULL )
328    {
329      if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
330               ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) &&
331               (!strcmp(p->type->name,"integer") ||
332                        !strcmp(p->type->name,"real") ||
333                        !strcmp(p->type->name,"doubleprecision"))
334              )
335      {
336      }
337      else if ( p->type->type_type == DERIVED )
338      {
339        sprintf(x,"%s%s%%",structname,p->name ) ;
340        gen_dealloc2(fp,x, corename, p->type) ;
341      }
342    }
343  }
344  return(0) ;
345}
Note: See TracBrowser for help on using the repository browser.