gen_scalar_indices.c
References to this file elsewhere.
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
11 int
12 gen_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
60 int
61 gen_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
76 int
77 gen_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
87 int
88 gen_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
98 int
99 gen_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] ;
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 if ((c = index( assoc_namelist_var , '=' ))==NULL) continue ;
115 *c = '\0' ; c += 2 ;
116 strcpy( assoc_namelist_choice , c ) ;
117 if ((rconfig=get_rconfig_entry ( assoc_namelist_var )) == NULL )
118 { fprintf(stderr,
119 "WARNING: There is no associated namelist variable %s\n",
120 assoc_namelist_var) ; return(1) ; }
121 fprintf(fp," IF (model_config_rec%%%s%s==%s)THEN\n",
122 assoc_namelist_var,
123 (atoi(rconfig->nentries)!=1)?"(idomain)":"", /* a little tricky; atoi of nentries will be '0' for a string like max_domains */
124 assoc_namelist_choice) ;
125 strcpy(scalars_str,pkg->pkg_4dscalars) ;
126
127 if ((scalars = strtok_rentr(scalars_str,";", &pos1)) != NULL)
128 {
129 while ( scalars != NULL ) {
130
131 if ((c = strtok_rentr(scalars,":",&pos2)) != NULL) strcpy(assoc_4d,c) ; /* get name of associated 4d array */
132 if (strcmp(c,"-")) {
133 if ( (fourd=get_4d_entry( assoc_4d )) != NULL || !strcmp( assoc_4d, "state" ) ) {
134 for ( c = strtok_rentr(NULL,",",&pos2) ; c != NULL ; c = strtok_rentr(NULL,",",&pos2) )
135 {
136 if ( fourd != NULL && ( ( x = get_entry( c , fourd->members )) != NULL ) ) {
137 fprintf(fp," IF ( %s_index_table( PARAM_%s , idomain ) .lt. 1 ) THEN\n",assoc_4d,c) ;
138 fprintf(fp," %s_num_table(idomain) = %s_num_table(idomain) + 1\n",assoc_4d,assoc_4d) ;
139 fprintf(fp," P_%s = %s_num_table(idomain)\n",c,assoc_4d) ;
140 fprintf(fp," %s_index_table( PARAM_%s , idomain ) = P_%s\n",assoc_4d,c,c) ;
141 fprintf(fp," ELSE\n") ;
142 fprintf(fp," P_%s = %s_index_table( PARAM_%s , idomain )\n",c,assoc_4d,c) ;
143 fprintf(fp," END IF\n") ;
144 {
145 char fourd_bnd[NAMELEN] ;
146 /* check for the existence of a fourd boundary array associated with this 4D array */
147 /* set io_mask accordingly for gen_wrf_io to know that it should generate i/o for _b and _bt */
148 /* arrays */
149 sprintf(fourd_bnd,"%s_b",assoc_4d) ;
150 if ( get_entry( fourd_bnd ,Domain.fields) != NULL ) {
151 x->io_mask |= BOUNDARY ;
152 }
153 }
154 fprintf(fp," %s_stream_table( idomain, P_%s ) = %d\n",assoc_4d,c, x->io_mask ) ;
155 fprintf(fp," %s_dname_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->dname) ;
156 fprintf(fp," %s_desc_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->descrip) ;
157 fprintf(fp," %s_units_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->units) ;
158 fprintf(fp," F_%s = .TRUE.\n",c) ;
159 } else if ((p = get_entry( c , Domain.fields )) != NULL ) {
160 fprintf(fp2,"IF(TRIM(vname).EQ.'%s')THEN\n",p->name) ;
161 fprintf(fp2," IF(uses.EQ.0)THEN\n");
162 fprintf(fp2," in_use = model_config_rec%%%s%s.EQ.%s\n",assoc_namelist_var,(atoi(rconfig->nentries)!=1)?"(id)":"",assoc_namelist_choice) ;
163 fprintf(fp2," uses = 1\n") ;
164 fprintf(fp2," ELSE\n") ;
165 fprintf(fp2," in_use = in_use.OR.model_config_rec%%%s%s.EQ.%s\n",assoc_namelist_var,(atoi(rconfig->nentries)!=1)?"(idomain)":"",assoc_namelist_choice) ;
166 fprintf(fp2," ENDIF\n") ;
167 fprintf(fp2,"ENDIF\n") ;
168
169 } else {
170 fprintf(stderr, "WARNING: %s is not a member of 4D array %s\n",c,assoc_4d);continue;
171 }
172 }
173 } else {
174 fprintf(stderr, "WARNING: There is no 4D array named %s\n",assoc_4d);continue ;
175 }
176 }
177
178 scalars = strtok_rentr(NULL,";", &pos1) ;
179
180 }
181 }
182
183 fprintf(fp," END IF\n") ;
184 }
185
186 return(0) ;
187 }
188
189