source: lmdz_wrf/trunk/WRFV3/tools/gen_allocs.c @ 1185

Last change on this file since 1185 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 26.7 KB
Line 
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
13int
14gen_alloc ( char * dirname )
15{
16  gen_alloc1( dirname ) ; 
17  gen_ddt_write( dirname ) ;
18  return(0) ;
19}
20
21int
22get_count_for_alloc( node_t *node , int *numguys, int *stats)  ;  /* forward */
23
24int
25gen_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
53int
54get_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
75int
76nolistthese( char * ) ;
77
78int
79gen_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*/
119if ( 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.grid%%is_intermediate) THEN\n") ;
148          fprintf(fp,"   ALLOCATE( grid%%tail_statevars%%next )\n") ;
149          fprintf(fp,"   grid%%tail_statevars => grid%%tail_statevars%%next\n") ;
150          fprintf(fp,"   NULLIFY( grid%%tail_statevars%%next )\n" ) ;
151          fprintf(fp,"   grid%%tail_statevars%%ProcOrient    = '  '\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%%Description = '%s'\n",p->descrip ) ;
155          fprintf(fp,"   grid%%tail_statevars%%Units = '%s'\n",p->units ) ;
156          fprintf(fp,"   grid%%tail_statevars%%Type    = '%c'\n",p->type->name[0]) ;
157          fprintf(fp,"   grid%%tail_statevars%%Ntl = %d\n",p->ntl<2?0:tag+p->ntl*100 ) ; /* if single tl, then 0, else tl itself */
158          fprintf(fp,"   grid%%tail_statevars%%Restart  = %s\n", (p->restart)?".TRUE.":".FALSE." ) ;
159          fprintf(fp,"   grid%%tail_statevars%%Ndim    = %d\n",p->ndims ) ;
160          fprintf(fp,"   grid%%tail_statevars%%scalar_array  = .FALSE. \n" ) ;
161          fprintf(fp,"   grid%%tail_statevars%%%cfield_%1dd => %s%s\n",p->type->name[0],p->ndims, structname, fname ) ;
162          io_mask = p->io_mask ;
163          if ( io_mask != NULL ) {
164            int i ;
165            for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
166              fprintf(fp,"  grid%%tail_statevars%%streams(%d) = %d ! %08x \n", i+1, io_mask[i], io_mask[i] ) ;
167            }
168          }
169          fprintf(fp,"  ENDIF\n") ;
170        }
171      }
172      if ( sw == 1 ) {
173        for ( tag = 1 ; tag <= p->ntl ; tag++ )
174        {
175          strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
176          if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
177          else              strcpy(dname,dname_tmp) ;
178          if( !strcmp( p->type->name , "real" ) ||
179              !strcmp( p->type->name , "doubleprecision" )  ) { /* if a real */
180            fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
181                        structname ,
182                        fname ) ;
183          } else if ( !strcmp( p->type->name , "integer" ) ) {
184            fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
185                        structname ,
186                        fname ) ;
187          } else if ( !strcmp( p->type->name , "logical" ) ) {
188            fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
189                        structname ,
190                        fname ) ;
191          }
192        }
193      }
194    }
195    if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
196          (p->node_kind & FIELD) ||                /* scalar arrays                          */
197          (p->node_kind & FOURD) )                 /* scalar arrays                          */
198                         )
199    {
200      if ( p->type != NULL ) {
201        tchar = '?' ;
202        if      ( !strcmp( p->type->name , "real" ) )            { tchar = 'R' ; }
203        else if ( !strcmp( p->type->name , "doubleprecision" ) ) { tchar = 'D' ; }
204        else if ( !strcmp( p->type->name , "logical" ) )         { tchar = 'L' ; }
205        else if ( !strcmp( p->type->name , "integer" ) )         { tchar = 'I' ; }
206        else { fprintf(stderr,"WARNING: what is the type for %s ?\n", p->name) ; }
207      }
208      if ( p->node_kind & FOURD ) { sprintf(post,           ",num_%s)",field_name(t4,p,0)) ; 
209                                    sprintf(post_for_count, "*num_%s)",field_name(t4,p,0)) ; }
210      else                        { sprintf(post,           ")" ) ; 
211                                    sprintf(post_for_count, ")" ) ;   }
212      for ( tag = 1 ; tag <= p->ntl ; tag++ )
213      {
214        if ( !strcmp ( p->use , "_4d_bdy_array_") ) {
215          strcpy(fname,p->name) ;
216        } else {
217          strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
218        }
219
220/* check for errors in memory allocation */
221
222       if ( ! p->boundary_array ) { fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ; } 
223       else                       { fprintf(fp,"IF(.TRUE.") ; }
224
225       if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
226            ! ( p->nest_mask & INTERP_DOWN || p->nest_mask & FORCE_DOWN || p->nest_mask & INTERP_UP || p->nest_mask & SMOOTH_UP ) )
227       {
228         fprintf(fp,".AND.(.NOT.grid%%is_intermediate)") ;
229       }
230       if ( p->ntl > 1 && sw == 1 ) {
231         fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ;
232       }
233       fprintf(fp,")THEN\n") ;
234       if ( p->boundary_array && sw_new_bdys ) {
235         int bdy ;
236         for ( bdy = 1 ; bdy <= 4 ; bdy++ )
237         {
238           if( p->type != NULL && tchar != '?' ) {
239             fprintf(fp,"  num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
240                         array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"),
241                         tchar) ;
242           }
243           if ( sw == 1 ) {
244             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",
245                structname, fname, bdy_indicator(bdy),
246                dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"), 
247                structname, fname, bdy_indicator(bdy),
248                dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%")); 
249             fprintf(fp, "  IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy));
250             if( p->type != NULL  &&   (!strcmp( p->type->name , "real" )
251                                   || !strcmp( p->type->name , "doubleprecision") ) )   {
252             /* if a real */
253               fprintf(fp, "initial_data_value\n");
254             } else if ( !strcmp( p->type->name , "logical" ) ) {
255               fprintf(fp, ".FALSE.\n");
256             } else if ( !strcmp( p->type->name , "integer" ) ) {
257               fprintf(fp, "0\n");
258             }
259           }
260         }
261       } else {
262         if( p->type != NULL && tchar != '?' ) {
263           fprintf(fp,"  num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
264                   array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
265                   tchar) ;
266         }
267         if ( sw == 1 ) {
268           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",
269                structname, fname,
270                dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"), 
271                structname, fname,
272                dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%")); 
273           fprintf(fp, "  IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
274
275           if( p->type != NULL  &&   (!strcmp( p->type->name , "real" ) 
276                                   || !strcmp( p->type->name , "doubleprecision") ) )   {
277           /* if a real */
278             fprintf(fp, "initial_data_value\n");
279           } else if ( !strcmp( p->type->name , "logical" ) ) {
280             fprintf(fp, ".FALSE.\n");
281           } else if ( !strcmp( p->type->name , "integer" ) ) {
282             fprintf(fp, "0\n");
283           }
284
285           if ( p->type->name[0] == 'l' && p->ndims >= 3 ) {
286             fprintf(stderr,"ADVISORY: %1dd logical array %s is allowed but cannot be input or output\n",
287                             p->ndims, p->name ) ;
288
289           }
290
291           if ( p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) &&
292                ! ( p->type->name[0] == 'l' && p->ndims >= 3 ) )  /* dont list logical arrays larger than 2d  */
293           { 
294             char memord[NAMELEN], stagstr[NAMELEN] ;
295             char *ornt ;
296
297             if      ( p->proc_orient == ALL_X_ON_PROC ) ornt = "X" ;
298             else if ( p->proc_orient == ALL_Y_ON_PROC ) ornt = "Y" ;
299             else                                        ornt = " " ;
300
301             strcpy(stagstr, "") ;
302             if ( p->node_kind & FOURD ) {
303               set_mem_order( p->members, memord , NAMELEN) ;
304               if ( p->members->stag_x ) strcat(stagstr, "X") ;
305               if ( p->members->stag_y ) strcat(stagstr, "Y") ;
306               if ( p->members->stag_z ) strcat(stagstr, "Z") ;
307             } else {
308               set_mem_order( p, memord , NAMELEN) ;
309               if ( p->stag_x ) strcat(stagstr, "X") ;
310               if ( p->stag_y ) strcat(stagstr, "Y") ;
311               if ( p->stag_z ) strcat(stagstr, "Z") ;
312             }
313             memord[3] = '\0' ; /* snip off any extra dimensions */
314
315             if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
316             else                                    strcpy(dname,dname_tmp) ;
317
318             fprintf(fp,"  IF (.NOT.grid%%is_intermediate) THEN\n") ; /*{*/
319             fprintf(fp,"  ALLOCATE( grid%%tail_statevars%%next )\n" ) ;
320             fprintf(fp,"  grid%%tail_statevars => grid%%tail_statevars%%next\n") ;
321             fprintf(fp,"  NULLIFY( grid%%tail_statevars%%next )\n") ;
322             fprintf(fp,"  grid%%tail_statevars%%VarName = '%s'\n", fname) ;
323             fprintf(fp,"  grid%%tail_statevars%%DataName = '%s'\n", dname) ;
324             fprintf(fp,"  grid%%tail_statevars%%Description = '%s'\n",p->descrip ) ;
325             fprintf(fp,"  grid%%tail_statevars%%Units = '%s'\n",p->units ) ;
326             fprintf(fp,"  grid%%tail_statevars%%Type    = '%c'\n", p->type->name[0]) ;
327             fprintf(fp,"  grid%%tail_statevars%%ProcOrient    = '%s'\n", ornt) ;
328             fprintf(fp,"  grid%%tail_statevars%%MemoryOrder  = '%s'\n", memord) ;
329             fprintf(fp,"  grid%%tail_statevars%%Stagger      = '%s'\n", stagstr) ;
330                           /* in next line for Ntl, if single tl, then zero, otherwise tl itself */
331             fprintf(fp,"  grid%%tail_statevars%%Ntl     = %d\n", p->ntl<2?0:tag+p->ntl*100 ) ;
332             fprintf(fp,"  grid%%tail_statevars%%Ndim    = %d\n", nd ) ;
333             restart = 0 ;
334             if ( p->node_kind & FOURD ) {
335               node_t *q ;
336               for ( q = p->members ; q->next != NULL ; q = q->next ) {  /* use the last one */
337                 if ( q != NULL ) {
338                   restart = q->restart ;
339                 }
340               }
341             } else {
342               restart = p->restart ;
343             }
344             fprintf(fp,"  grid%%tail_statevars%%Restart  = %s\n", (restart)?".TRUE.":".FALSE." ) ;
345             fprintf(fp,"  grid%%tail_statevars%%scalar_array = %s\n", (p->node_kind & FOURD)?".TRUE.":".FALSE.") ;
346             fprintf(fp,"  grid%%tail_statevars%%%cfield_%1dd => %s%s\n", p->type->name[0],nd, structname, fname ) ;
347             if ( p->node_kind & FOURD ) {
348               fprintf(fp,"  grid%%tail_statevars%%num_table => %s_num_table\n",   p->name ) ;
349               fprintf(fp,"  grid%%tail_statevars%%index_table => %s_index_table\n",   p->name ) ;
350               fprintf(fp,"  grid%%tail_statevars%%boundary_table => %s_boundary_table\n",   p->name ) ;
351               fprintf(fp,"  grid%%tail_statevars%%dname_table => %s_dname_table\n",   p->name ) ;
352               fprintf(fp,"  grid%%tail_statevars%%desc_table => %s_desc_table\n",   p->name ) ;
353               fprintf(fp,"  grid%%tail_statevars%%units_table => %s_units_table\n",   p->name ) ;
354               fprintf(fp,"  grid%%tail_statevars%%streams_table => %s_streams_table\n",   p->name ) ;
355             } 
356
357             if ( p->node_kind & FOURD ) {
358               node_t *q ;
359               io_mask = NULL ;
360               for ( q = p->members ; q->next != NULL ; q = q->next ) {  /* use the last one */
361                 if ( q != NULL ) {
362                   io_mask = q->io_mask ;
363                 }
364               }
365             } else {
366               io_mask = p->io_mask ;
367             }
368
369             if ( io_mask != NULL ) {
370               int i ;
371               for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
372                 fprintf(fp,"  grid%%tail_statevars%%streams(%d) = %d ! %08x \n",  i+1, io_mask[i], io_mask[i] ) ;
373               }
374             }
375
376             {
377               char ddim[3][2][NAMELEN] ;
378               char mdim[3][2][NAMELEN] ;
379               char pdim[3][2][NAMELEN] ;
380
381               set_dim_strs3( p, ddim, mdim, pdim , "", 0 ) ;           /* dimensions with staggering */
382
383               fprintf(fp,"  grid%%tail_statevars%%sd1 = %s\n", ddim[0][0] ) ;
384               fprintf(fp,"  grid%%tail_statevars%%ed1 = %s\n", ddim[0][1] ) ;
385               fprintf(fp,"  grid%%tail_statevars%%sd2 = %s\n", ddim[1][0] ) ;
386               fprintf(fp,"  grid%%tail_statevars%%ed2 = %s\n", ddim[1][1] ) ;
387               fprintf(fp,"  grid%%tail_statevars%%sd3 = %s\n", ddim[2][0] ) ;
388               fprintf(fp,"  grid%%tail_statevars%%ed3 = %s\n", ddim[2][1] ) ;
389               fprintf(fp,"  grid%%tail_statevars%%sm1 = %s\n", mdim[0][0] ) ;
390               fprintf(fp,"  grid%%tail_statevars%%em1 = %s\n", mdim[0][1] ) ;
391               fprintf(fp,"  grid%%tail_statevars%%sm2 = %s\n", mdim[1][0] ) ;
392               fprintf(fp,"  grid%%tail_statevars%%em2 = %s\n", mdim[1][1] ) ;
393               fprintf(fp,"  grid%%tail_statevars%%sm3 = %s\n", mdim[2][0] ) ;
394               fprintf(fp,"  grid%%tail_statevars%%em3 = %s\n", mdim[2][1] ) ;
395               fprintf(fp,"  grid%%tail_statevars%%sp1 = %s\n", pdim[0][0] ) ;
396               fprintf(fp,"  grid%%tail_statevars%%ep1 = %s\n", pdim[0][1] ) ;
397               fprintf(fp,"  grid%%tail_statevars%%sp2 = %s\n", pdim[1][0] ) ;
398               fprintf(fp,"  grid%%tail_statevars%%ep2 = %s\n", pdim[1][1] ) ;
399               fprintf(fp,"  grid%%tail_statevars%%sp3 = %s\n", pdim[2][0] ) ;
400               fprintf(fp,"  grid%%tail_statevars%%ep3 = %s\n", pdim[2][1] ) ;
401
402             }
403             {
404               int i ;
405               node_t * dimnode ;
406               for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
407               for ( i = 0 ; i < 3 ; i++ )
408               {
409                 if (( dimnode = p->dims[i]) != NULL )
410                 {
411                   switch ( dimnode->coord_axis )
412                   {
413                   case (COORD_X) :
414                     if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
415                      { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
416                     else if ( p->dims[i]->subgrid )
417                      { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
418                     else
419                      { strcpy( dimname[i], dimnode->dim_data_name) ; }
420                     fprintf(fp,"  grid%%tail_statevars%%subgrid_x = %s\n",(p->dims[i]->subgrid)?".TRUE.":".FALSE.") ;
421                     break ;
422                   case (COORD_Y) :
423                     if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
424                      { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
425                     else if ( p->dims[i]->subgrid )
426                      { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
427                     else
428                      { strcpy( dimname[i], dimnode->dim_data_name) ; }
429                     fprintf(fp,"  grid%%tail_statevars%%subgrid_y = %s\n",(p->dims[i]->subgrid)?".TRUE.":".FALSE.") ;
430                     break ;
431                   case (COORD_Z) :
432                     if ( p->stag_z )
433                      { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
434                     else if ( p->dims[i]->subgrid )
435                      { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
436                     else
437                      { strcpy( dimname[i], dimnode->dim_data_name) ; }
438                     break ;
439                   }
440                 }
441               }
442               fprintf(fp,"  grid%%tail_statevars%%dimname1 = '%s'\n", dimname[0] ) ;
443               fprintf(fp,"  grid%%tail_statevars%%dimname2 = '%s'\n", dimname[1] ) ;
444               fprintf(fp,"  grid%%tail_statevars%%dimname3 = '%s'\n", dimname[2] ) ;
445             }
446             fprintf(fp,"  ENDIF\n") ; /*}*/
447           }
448         }
449       }
450
451       fprintf(fp,"ELSE\n") ;
452
453       if ( p->boundary_array && sw_new_bdys ) {
454         int bdy ;
455         for ( bdy = 1 ; bdy <= 4 ; bdy++ )
456         {
457           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",
458                structname, fname,  bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ), 
459                structname, fname,  bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ;
460         }
461       } else {
462           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",
463                structname, fname, dimension_with_ones( "(",t2,p,")" ), 
464                structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
465
466       }
467
468       fprintf(fp,"ENDIF\n") ;  /* end of in_use conditional */
469
470      }
471    }
472    if ( p->type != NULL )
473    {
474      if ( p->type->type_type == DERIVED )
475      {
476        sprintf(x,"%s%s%%",structname,p->name ) ;
477        gen_alloc2(fp,x, p->type, j, iguy, fraction, numguys, 1, sw) ;
478      }
479    }
480  } /* fraction loop */
481  return(0) ;
482}
483
484#if 0
485int
486gen_alloc_count ( char * dirname )
487{
488  gen_alloc_count1( dirname ) ;
489  return(0) ;
490}
491
492int
493gen_alloc_count1 ( char * dirname )
494{
495  FILE * fp ;
496  char  fname[NAMELEN] ;
497  char * fn = "alloc_count.inc" ;
498
499  if ( dirname == NULL ) return(1) ;
500  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
501  else                       { sprintf(fname,"%s",fn) ; }
502  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
503  print_warning(fp,fname) ;
504  gen_alloc2( fp , "grid%", &Domain, 0 ) ;
505  close_the_file( fp ) ;
506  return(0) ;
507}
508#endif
509
510int
511gen_ddt_write ( char * dirname )
512{
513  FILE * fp ;
514  char  fname[NAMELEN] ;
515  char * fn = "write_ddt.inc" ;
516
517  if ( dirname == NULL ) return(1) ;
518  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
519  else                       { sprintf(fname,"%s",fn) ; }
520  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
521  print_warning(fp,fname) ;
522  gen_ddt_write1( fp , "grid%", &Domain ) ;
523  close_the_file( fp ) ;
524  return(0) ;
525}
526
527int
528gen_ddt_write1 ( FILE * fp , char * structname , node_t * node )
529{
530  node_t * p ;
531  int tag ;
532  char post[NAMELEN] ;
533  char fname[NAMELEN] ;
534  char x[NAMELEN] ;
535
536  if ( node == NULL ) return(1) ;
537
538  for ( p = node->fields ; p != NULL ; p = p->next )
539  {
540    if ( (p->ndims > 1 && ! p->boundary_array) && (  /* any array or a boundary array and...   */
541          (p->node_kind & FIELD) ||                  /* scalar arrays or...                    */
542          (p->node_kind & FOURD) )                   /* scalar arrays or...                    */
543                         )
544    {
545      if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
546      else                        { sprintf(post,")") ; }
547      for ( tag = 1 ; tag <= p->ntl ; tag++ )
548      {
549       strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
550
551       if ( p->node_kind & FOURD ) {
552         fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
553       } else {
554         if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
555         if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
556       }
557
558      }
559    }
560  }
561  return(0) ;
562}
563
564int
565gen_dealloc ( char * dirname )
566{
567  gen_dealloc1( dirname ) ; 
568  return(0) ;
569}
570
571int
572gen_dealloc1 ( char * dirname )
573{
574  FILE * fp ;
575  char  fname[NAMELEN] ;
576  char * fn = "deallocs.inc" ;
577
578  if ( dirname == NULL ) return(1) ;
579  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
580  else                       { sprintf(fname,"%s",fn) ; }
581  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
582  print_warning(fp,fname) ;
583  gen_dealloc2( fp , "grid%", &Domain ) ;
584  close_the_file( fp ) ;
585  return(0) ;
586}
587
588int
589gen_dealloc2 ( FILE * fp , char * structname , node_t * node )
590{
591  node_t * p ;
592  int tag ;
593  char post[NAMELEN] ;
594  char fname[NAMELEN] ;
595  char x[NAMELEN] ;
596
597  if ( node == NULL ) return(1) ;
598
599  for ( p = node->fields ; p != NULL ; p = p->next )
600  {
601    if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
602          (p->node_kind & FIELD) ||                /* scalar arrays or                       */
603          (p->node_kind & FOURD) )                 /* scalar arrays or                       */
604                         )
605    {
606      if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
607      else                        { sprintf(post,")") ; }
608      for ( tag = 1 ; tag <= p->ntl ; tag++ )
609      {
610        strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
611
612        if ( p->boundary && sw_new_bdys ) {
613          { int bdy ; 
614            for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
615#ifdef USE_ALLOCATABLES
616                  fprintf(fp,
617"IF ( ALLOCATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
618#else
619                  fprintf(fp,
620"IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
621#endif
622                  fprintf(fp,
623"  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",
624          structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ;
625#ifndef USE_ALLOCATABLES
626                  fprintf(fp,
627"  NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ;
628#endif
629                  fprintf(fp, 
630"ENDIF\n" ) ;
631            }
632          }
633        } else {
634#ifdef USE_ALLOCATABLES
635        fprintf(fp,
636"IF ( ALLOCATED( %s%s ) ) THEN \n", structname, fname ) ;
637#else
638        fprintf(fp,
639"IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
640#endif
641        fprintf(fp, 
642"  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",
643structname, fname, structname, fname ) ;
644#ifdef USE_ALLOCATABLES
645        fprintf(fp,
646"  NULLIFY(%s%s)\n",structname, fname ) ;
647#endif
648        fprintf(fp,
649"ENDIF\n" ) ;
650        }
651
652
653      }
654    }
655    if ( p->type != NULL )
656    {
657      if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
658               (!strcmp(p->type->name,"integer") ||
659                        !strcmp(p->type->name,"real") ||
660                        !strcmp(p->type->name,"doubleprecision"))
661              )
662      {
663      }
664      else if ( p->type->type_type == DERIVED )
665      {
666        sprintf(x,"%s%s%%",structname,p->name ) ;
667        gen_dealloc2(fp,x, p->type) ;
668      }
669    }
670  }
671  return(0) ;
672}
673
674int
675nolistthese( char * name )
676{
677   return(
678             !strncmp(name,"auxhist",7)
679          || !strncmp(name,"auxinput",8)
680          || !strncmp(name,"oid",3)
681         ) ;
682}
Note: See TracBrowser for help on using the repository browser.