source: trunk/WRF.COMMON/WRFV2/tools/gen_scalar_indices.c @ 3547

Last change on this file since 3547 was 11, checked in by aslmd, 14 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien

File size: 5.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
10
11int
12gen_scalar_indices ( char * dirname )
13{
14  FILE * fp ;
15  char  fname[NAMELEN] ;
16  char * fn = "scalar_indices.inc" ;
17  char * fn2 = "scalar_tables.inc" ;
18  char * fn3 = "scalar_tables_init.inc" ;
19  char * fn4 = "scalar_indices_init.inc" ;
20
21  strcpy( fname, fn ) ;
22  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
23  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
24  print_warning(fp,fname) ;
25  gen_scalar_indices1 ( fp ) ;
26  close_the_file( fp ) ;
27
28  strcpy( fname, fn2 ) ;
29  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn2) ; }
30  if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; }
31  print_warning(fp,fname) ;
32  gen_scalar_tables ( fp ) ;
33  close_the_file( fp ) ;
34
35  strcpy( fname, fn3 ) ;
36  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn3) ; }
37  if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; }
38  print_warning(fp,fname) ;
39  gen_scalar_tables_init ( fp ) ;
40  close_the_file( fp ) ;
41
42  strcpy( fname, fn4 ) ;
43  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn4) ; }
44  if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; }
45  print_warning(fp,fname) ;
46  gen_scalar_indices_init ( fp ) ;
47  close_the_file( fp ) ;
48
49  return(0) ;
50}
51
52int
53gen_scalar_tables ( FILE * fp )
54{
55  node_t * p ;
56  for ( p = FourD ; p != NULL ; p=p->next4d )
57  {
58    fprintf(fp,"  INTEGER :: %s_index_table( param_num_%s, max_domains )\n",p->name,p->name )  ;
59    fprintf(fp,"  INTEGER :: %s_num_table( max_domains )\n", p->name,p->name ) ;
60    fprintf(fp,"  INTEGER :: %s_stream_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
61    fprintf(fp,"  CHARACTER*256 :: %s_dname_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
62    fprintf(fp,"  CHARACTER*256 :: %s_desc_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
63    fprintf(fp,"  CHARACTER*256 :: %s_units_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
64  }
65  return(0) ;
66}
67
68int
69gen_scalar_tables_init ( FILE * fp )
70{
71  node_t * p ;
72  for ( p = FourD ; p != NULL ; p=p->next4d )
73  {
74    fprintf(fp,"  %s_num_table( j ) = 1\n",p->name )  ;
75  }
76  return(0) ;
77}
78
79int
80gen_scalar_indices_init ( FILE * fp )
81{
82  node_t * p ;
83  for ( p = FourD ; p != NULL ; p=p->next4d )
84  {
85    fprintf(fp,"  num_%s = %s_num_table( idomain )\n",p->name,p->name )  ;
86  }
87  return(0) ;
88}
89
90int
91gen_scalar_indices1 ( FILE * fp )
92{
93  node_t * p, * memb , * pkg, * rconfig, * fourd, *x ; 
94  char * c , *pos1, *pos2 ;
95  char assoc_namelist_var[NAMELEN], assoc_namelist_choice[NAMELEN], assoc_4d[NAMELEN] ;
96  char scalars_str[NAMELEN] ;
97  char * scalars ;
98
99  for ( p = FourD ; p != NULL ; p = p->next )
100   { for ( memb = p->members ; memb != NULL ; memb = memb->next )
101      { if ( strcmp(memb->name,"-") ) fprintf(fp,"  P_%s = 1 ; F_%s = .FALSE. \n", memb->name, memb->name ) ; } }
102
103  for ( pkg = Packages ; pkg != NULL ; pkg = pkg->next )
104  {
105    strcpy( assoc_namelist_var , pkg->pkg_assoc ) ;
106    if ((c = index( assoc_namelist_var , '=' ))==NULL) continue ;
107    *c = '\0' ; c += 2 ;
108    strcpy( assoc_namelist_choice , c ) ;
109    if ((rconfig=get_rconfig_entry ( assoc_namelist_var )) == NULL )
110     { fprintf(stderr,
111       "WARNING: There is no associated namelist variable %s\n",
112        assoc_namelist_var) ; return(1) ; }
113    fprintf(fp,"  IF (model_config_rec%%%s%s==%s)THEN\n",
114                 assoc_namelist_var,
115                 (atoi(rconfig->nentries)!=1)?"(idomain)":"",  /* a little tricky; atoi of nentries will be '0' for a string like max_domains */
116                 assoc_namelist_choice) ;
117    strcpy(scalars_str,pkg->pkg_4dscalars) ;
118
119    if ((scalars = strtok_rentr(scalars_str,";", &pos1)) != NULL)
120    {
121      while ( scalars != NULL ) {
122
123        if ((c = strtok_rentr(scalars,":",&pos2)) != NULL) strcpy(assoc_4d,c) ; /* get name of associated 4d array */
124        if (strcmp(c,"-")) {
125          if ((fourd=get_4d_entry( assoc_4d )) == NULL )
126           { fprintf(stderr, "WARNING: There is no 4D array named %s\n",assoc_4d);continue;}
127          for ( c = strtok_rentr(NULL,",",&pos2) ; c != NULL ; c = strtok_rentr(NULL,",",&pos2) )
128          {
129            if ( ( x = get_entry( c , fourd->members )) == NULL )
130              { fprintf(stderr, "WARNING: %s is not a member of 4D array %s\n",c,assoc_4d);continue;}
131            fprintf(fp,"   IF ( %s_index_table( PARAM_%s , idomain ) .lt. 1 ) THEN\n",assoc_4d,c) ;
132            fprintf(fp,"     %s_num_table(idomain) = %s_num_table(idomain) + 1\n",assoc_4d,assoc_4d) ;
133            fprintf(fp,"     P_%s = %s_num_table(idomain)\n",c,assoc_4d) ;
134            fprintf(fp,"     %s_index_table( PARAM_%s , idomain ) = P_%s\n",assoc_4d,c,c) ;
135            fprintf(fp,"   ELSE\n") ;
136            fprintf(fp,"     P_%s = %s_index_table( PARAM_%s , idomain )\n",c,assoc_4d,c)  ;
137            fprintf(fp,"   END IF\n") ;
138            {
139              char fourd_bnd[NAMELEN] ;
140              /* check for the existence of a fourd boundary array associated with this 4D array */
141              /* set io_mask accordingly for gen_wrf_io to know that it should generate i/o for _b and _bt */
142              /* arrays */
143              sprintf(fourd_bnd,"%s_b",assoc_4d) ;
144              if ( get_entry( fourd_bnd  ,Domain.fields) != NULL ) {
145                 x->io_mask |= BOUNDARY ;
146              }
147            }
148            fprintf(fp,"   %s_stream_table( idomain, P_%s ) = %d\n",assoc_4d,c, x->io_mask ) ;
149            fprintf(fp,"   %s_dname_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->dname) ;
150            fprintf(fp,"   %s_desc_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->descrip) ;
151            fprintf(fp,"   %s_units_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->units) ;
152            fprintf(fp,"   F_%s = .TRUE.\n",c) ;
153          }
154        }
155
156        scalars = strtok_rentr(NULL,";", &pos1) ;
157
158      }
159    }
160
161    fprintf(fp,"  END IF\n") ;
162  }
163
164  return(0) ;
165}
166
167
Note: See TracBrowser for help on using the repository browser.