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 ;
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
52 int
53 gen_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
68 int
69 gen_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
79 int
80 gen_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
90 int
91 gen_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_LONG] ;
96 char scalars_str[NAMELEN_LONG] ;
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