source: trunk/WRF.COMMON/WRFV3/tools/gen_scalar_indices.c @ 3094

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