source: trunk/WRF.COMMON/WRFV3/tools/gen_allocs.c @ 3431

Last change on this file since 3431 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 12.9 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  gen_alloc1( dirname ) ; 
14  gen_ddt_write( dirname ) ;
15  return(0) ;
16}
17
18int
19gen_alloc1 ( char * dirname )
20{
21  FILE * fp ;
22  char  fname[NAMELEN] ;
23  char * fn = "allocs.inc" ;
24
25  if ( dirname == NULL ) return(1) ;
26  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
27  else                       { sprintf(fname,"%s",fn) ; }
28  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
29  print_warning(fp,fname) ;
30  gen_alloc2( fp , "grid%", &Domain, 1 ) ;
31  close_the_file( fp ) ;
32  return(0) ;
33}
34
35int
36gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allocate, 2 = just count */
37{
38  node_t * p ;
39  int tag ;
40  char post[NAMELEN], post_for_count[NAMELEN] ;
41  char fname[NAMELEN] ;
42  char x[NAMELEN] ;
43  char tchar ;
44
45  if ( node == NULL ) return(1) ;
46
47  for ( p = node->fields ; p != NULL ; p = p->next )
48  {
49    if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
50          (p->node_kind & FIELD) ||                /* scalar arrays                          */
51          (p->node_kind & FOURD) )                 /* scalar arrays                          */
52                         )
53    {
54      if ( p->type != NULL ) {
55        tchar = '?' ;
56        if      ( !strcmp( p->type->name , "real" ) )            { tchar = 'R' ; }
57        else if ( !strcmp( p->type->name , "doubleprecision" ) ) { tchar = 'D' ; }
58        else if ( !strcmp( p->type->name , "logical" ) )         { tchar = 'L' ; }
59        else if ( !strcmp( p->type->name , "integer" ) )         { tchar = 'I' ; }
60        else { fprintf(stderr,"WARNING: what is the type for %s ?\n", p->name) ; }
61      }
62      if ( p->node_kind & FOURD ) { sprintf(post,           ",num_%s)",field_name(t4,p,0)) ; 
63                                    sprintf(post_for_count, "*num_%s)",field_name(t4,p,0)) ; }
64      else                        { sprintf(post,           ")" ) ; 
65                                    sprintf(post_for_count, ")" ) ;   }
66      for ( tag = 1 ; tag <= p->ntl ; tag++ )
67      {
68        if ( !strcmp ( p->use , "_4d_bdy_array_") ) {
69          strcpy(fname,p->name) ;
70        } else {
71          strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
72        }
73
74/* check for errors in memory allocation */
75
76       if ( ! p->boundary_array ) { fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ; } 
77       else                       { fprintf(fp,"IF(.TRUE.") ; }
78       if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
79            ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) )
80       {
81         fprintf(fp,".AND.(.NOT.inter_domain)",tag) ;
82       }
83       if ( p->ntl > 1 && sw == 1 ) {
84         fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ;
85       }
86       fprintf(fp,")THEN\n") ;
87       if ( p->boundary_array && sw_new_bdys ) {
88         int bdy ;
89         for ( bdy = 1 ; bdy <= 4 ; bdy++ )
90         {
91           if( p->type != NULL && tchar != '?' ) {
92             fprintf(fp,"  num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
93                         array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"),
94                         tchar) ;
95           }
96           if ( sw == 1 ) {
97             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",
98                structname, fname, bdy_indicator(bdy),
99                dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"), 
100                structname, fname, bdy_indicator(bdy),
101                dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%")); 
102             fprintf(fp, "  IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy));
103             if( p->type != NULL  &&   (!strcmp( p->type->name , "real" )
104                                   || !strcmp( p->type->name , "doubleprecision") ) )   {
105             /* if a real */
106               fprintf(fp, "initial_data_value\n");
107             } else if ( !strcmp( p->type->name , "logical" ) ) {
108               fprintf(fp, ".FALSE.\n");
109             } else if ( !strcmp( p->type->name , "integer" ) ) {
110               fprintf(fp, "0\n");
111             }
112           }
113         }
114       } else {
115         if( p->type != NULL && tchar != '?' ) {
116           fprintf(fp,"  num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
117                   array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
118                   tchar) ;
119         }
120         if ( sw == 1 ) {
121           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",
122                structname, fname,
123                dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"), 
124                structname, fname,
125                dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%")); 
126           fprintf(fp, "  IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
127
128           if( p->type != NULL  &&   (!strcmp( p->type->name , "real" ) 
129                                 || !strcmp( p->type->name , "doubleprecision") ) )   {
130           /* if a real */
131             fprintf(fp, "initial_data_value\n");
132           } else if ( !strcmp( p->type->name , "logical" ) ) {
133             fprintf(fp, ".FALSE.\n");
134           } else if ( !strcmp( p->type->name , "integer" ) ) {
135             fprintf(fp, "0\n");
136           }
137         }
138       }
139
140       fprintf(fp,"ELSE\n") ;
141
142       if ( p->boundary_array && sw_new_bdys ) {
143         int bdy ;
144         for ( bdy = 1 ; bdy <= 4 ; bdy++ )
145         {
146           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",
147                structname, fname,  bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ), 
148                structname, fname,  bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ;
149         }
150       } else {
151           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",
152                structname, fname, dimension_with_ones( "(",t2,p,")" ), 
153                structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
154
155       }
156
157       fprintf(fp,"ENDIF\n") ;  /* end of in_use conditional */
158
159      }
160    }
161    if ( p->type != NULL )
162    {
163      if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
164               (!strcmp(p->type->name,"integer") || 
165                        !strcmp(p->type->name,"logical") || 
166                        !strcmp(p->type->name,"real") ||
167                        !strcmp(p->type->name,"doubleprecision"))
168              )
169      {
170          strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
171          if ( sw == 1 ) {
172            if( !strcmp( p->type->name , "real" ) || 
173                !strcmp( p->type->name , "doubleprecision" )  ) { /* if a real */
174              fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
175                          structname ,
176                          fname ) ;
177            } else if ( !strcmp( p->type->name , "integer" ) ) {
178              fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
179                          structname ,
180                          fname ) ;
181            } else if ( !strcmp( p->type->name , "logical" ) ) {
182              fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
183                          structname ,
184                          fname ) ;
185            }
186          }
187      }
188      else if ( p->type->type_type == DERIVED )
189      {
190        sprintf(x,"%s%s%%",structname,p->name ) ;
191        gen_alloc2(fp,x, p->type, sw) ;
192      }
193    }
194  }
195  return(0) ;
196}
197
198int
199gen_alloc_count ( char * dirname )
200{
201  gen_alloc_count1( dirname ) ;
202  return(0) ;
203}
204
205int
206gen_alloc_count1 ( char * dirname )
207{
208  FILE * fp ;
209  char  fname[NAMELEN] ;
210  char * fn = "alloc_count.inc" ;
211
212  if ( dirname == NULL ) return(1) ;
213  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
214  else                       { sprintf(fname,"%s",fn) ; }
215  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
216  print_warning(fp,fname) ;
217  gen_alloc2( fp , "grid%", &Domain, 0 ) ;
218  close_the_file( fp ) ;
219  return(0) ;
220}
221
222int
223gen_ddt_write ( char * dirname )
224{
225  FILE * fp ;
226  char  fname[NAMELEN] ;
227  char * fn = "write_ddt.inc" ;
228
229  if ( dirname == NULL ) return(1) ;
230  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
231  else                       { sprintf(fname,"%s",fn) ; }
232  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
233  print_warning(fp,fname) ;
234  gen_ddt_write1( fp , "grid%", &Domain ) ;
235  close_the_file( fp ) ;
236  return(0) ;
237}
238
239int
240gen_ddt_write1 ( FILE * fp , char * structname , node_t * node )
241{
242  node_t * p ;
243  int tag ;
244  char post[NAMELEN] ;
245  char fname[NAMELEN] ;
246  char x[NAMELEN] ;
247
248  if ( node == NULL ) return(1) ;
249
250  for ( p = node->fields ; p != NULL ; p = p->next )
251  {
252    if ( (p->ndims > 1 && ! p->boundary_array) && (  /* any array or a boundary array and...   */
253          (p->node_kind & FIELD) ||                  /* scalar arrays or...                    */
254          (p->node_kind & FOURD) )                   /* scalar arrays or...                    */
255                         )
256    {
257      if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
258      else                        { sprintf(post,")") ; }
259      for ( tag = 1 ; tag <= p->ntl ; tag++ )
260      {
261       strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
262
263       if ( p->node_kind & FOURD ) {
264         fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
265       } else {
266         if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
267         if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
268       }
269
270      }
271    }
272  }
273  return(0) ;
274}
275
276int
277gen_dealloc ( char * dirname )
278{
279  gen_dealloc1( dirname ) ; 
280  return(0) ;
281}
282
283int
284gen_dealloc1 ( char * dirname )
285{
286  FILE * fp ;
287  char  fname[NAMELEN] ;
288  char * fn = "deallocs.inc" ;
289
290  if ( dirname == NULL ) return(1) ;
291  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
292  else                       { sprintf(fname,"%s",fn) ; }
293  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
294  print_warning(fp,fname) ;
295  gen_dealloc2( fp , "grid%", &Domain ) ;
296  close_the_file( fp ) ;
297  return(0) ;
298}
299
300int
301gen_dealloc2 ( FILE * fp , char * structname , node_t * node )
302{
303  node_t * p ;
304  int tag ;
305  char post[NAMELEN] ;
306  char fname[NAMELEN] ;
307  char x[NAMELEN] ;
308
309  if ( node == NULL ) return(1) ;
310
311  for ( p = node->fields ; p != NULL ; p = p->next )
312  {
313    if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
314          (p->node_kind & FIELD) ||                /* scalar arrays or                       */
315          (p->node_kind & FOURD) )                 /* scalar arrays or                       */
316                         )
317    {
318      if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
319      else                        { sprintf(post,")") ; }
320      for ( tag = 1 ; tag <= p->ntl ; tag++ )
321      {
322        strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
323
324        if ( p->boundary && sw_new_bdys ) {
325          { int bdy ; 
326            for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
327                  fprintf(fp,
328"IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
329                  fprintf(fp,
330"  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",
331          structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ;
332                  fprintf(fp,
333"  NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ;
334                  fprintf(fp, 
335"ENDIF\n" ) ;
336            }
337          }
338        } else {
339        fprintf(fp,
340"IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
341        fprintf(fp, 
342"  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",
343structname, fname, structname, fname ) ;
344        fprintf(fp,
345"  NULLIFY(%s%s)\n",structname, fname ) ;
346        fprintf(fp,
347"ENDIF\n" ) ;
348        }
349
350
351      }
352    }
353    if ( p->type != NULL )
354    {
355      if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
356               (!strcmp(p->type->name,"integer") ||
357                        !strcmp(p->type->name,"real") ||
358                        !strcmp(p->type->name,"doubleprecision"))
359              )
360      {
361      }
362      else if ( p->type->type_type == DERIVED )
363      {
364        sprintf(x,"%s%s%%",structname,p->name ) ;
365        gen_dealloc2(fp,x, p->type) ;
366      }
367    }
368  }
369  return(0) ;
370}
Note: See TracBrowser for help on using the repository browser.