type.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 "registry.h"
7 #include "protos.h"
8 #include "data.h"
9
10 int
11 init_type_table()
12 {
13 node_t *p ;
14 p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "integer" ) ; add_node_to_end ( p , &Type ) ;
15 p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "real" ) ; add_node_to_end ( p , &Type ) ;
16 p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "logical" ) ; add_node_to_end ( p , &Type ) ;
17 p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "character*256" ) ; add_node_to_end ( p , &Type ) ;
18 p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "doubleprecision" ) ; add_node_to_end ( p , &Type ) ;
19 return(0) ;
20 }
21
22 int
23 set_state_dims ( char * dims , node_t * node )
24 {
25 int modifiers ;
26 node_t *d, *d1 ;
27 char *c ;
28 int star ;
29
30 if ( dims == NULL ) dims = "-" ;
31 modifiers = 0 ;
32 node->proc_orient = ALL_Z_ON_PROC ; /* default */
33 node->ndims = 0 ;
34 node->boundary_array = 0 ;
35
36 star = 0 ;
37 node->subgrid = 0 ;
38 for ( c = dims ; *c ; c++ )
39 {
40 if ( *c == 'f' )
41 {
42 node->scalar_array_member = 1 ;
43 modifiers = 1 ;
44 }
45 else if ( *c == 't' )
46 {
47 node->has_scalar_array_tendencies = 1 ;
48 modifiers = 1 ;
49 }
50 else if ( *c == 'x' )
51 {
52 node->proc_orient = ALL_X_ON_PROC ;
53 modifiers = 1 ;
54 }
55 else if ( *c == 'y' )
56 {
57 node->proc_orient = ALL_Y_ON_PROC ;
58 modifiers = 1 ;
59 }
60 else if ( *c == 'b' )
61 {
62 node->boundary_array = 1 ;
63 modifiers = 1 ;
64 }
65 else if ( *c == '*' )
66 {
67 /* next dimspec seen represents a subgrid */
68 star = 1 ;
69 continue ;
70 }
71 else if ( *c == '-' )
72 {
73 break ;
74 }
75 else if ( modifiers == 0 )
76 {
77 if (( d = get_dim_entry ( *c )) == NULL ) { return(1) ; }
78 d1 = new_node( DIM) ; /* make a copy */
79 *d1 = *d ;
80 if ( star ) { d1->subgrid = 1 ; node->subgrid |= (1<<node->ndims) ; } /* mark the node has having a subgrid dim */
81 node->dims[node->ndims++] = d1 ;
82 star = 0 ;
83 }
84 }
85 return (0) ;
86 }
87
88 node_t *
89 get_4d_entry ( char * name )
90 {
91 node_t *p ;
92 if ( name == NULL ) return (NULL) ;
93 for ( p = FourD ; p != NULL ; p = p->next4d )
94 {
95 if ( !strcmp( p->name , name ) )
96 {
97 return(p) ;
98 }
99 }
100 return(NULL) ;
101 }
102
103 node_t *
104 get_type_entry ( char * typename )
105 {
106 return(get_entry(typename,Type)) ;
107 }
108
109 node_t *
110 get_rconfig_entry ( char * name )
111 {
112 node_t * p ;
113 if ((p=get_entry(name,Domain.fields))==NULL) return(NULL) ;
114 if (p->node_kind & RCONFIG) return(p) ;
115 return(NULL) ;
116 }
117
118 node_t *
119 get_entry ( char * name , node_t * node )
120 {
121 node_t *p ;
122 if ( name == NULL ) return (NULL) ;
123 if ( node == NULL ) return (NULL) ;
124 for ( p = node ; p != NULL ; p = p->next )
125 {
126 if ( !strcmp( name , "character" ) )
127 {
128 if ( !strncmp( p->name , name, 9 ) )
129 {
130 return(p) ;
131 }
132 } else {
133 if ( !strcmp( p->name , name ) )
134 {
135 return(p) ;
136 }
137 }
138
139
140 }
141 return(NULL) ;
142 }
143
144 /* this gets the entry for the node even if it */
145 /* is a derived data structure; does this by following */
146 /* the fully specified f90 reference. For example: */
147 /* "xa%f" for the field of derived type xa. */
148 /* note it will also take care to ignore the _1 or _2 */
149 /* suffixes from variables that have ntl > 1 */
150 /* 11/10/2001 -- added use field; if the entry has a use */
151 /* that starts with "dyn_" and use doesn't correspond to */
152 /* that, skip that entry and continue */
153
154 node_t *
155 get_entry_r ( char * name , char * use , node_t * node )
156 {
157 node_t *p ;
158 char tmp[NAMELEN], *t1, *t2 ;
159
160 if ( name == NULL ) return (NULL) ;
161 if ( node == NULL ) return (NULL) ;
162
163 for ( p = node ; p != NULL ; p = p->next )
164 {
165 if ( !strncmp( use, "dyn_", 4 ) && !strncmp( p->use, "dyn_", 4 ) && strcmp( p->use, use ) )
166 {
167 continue ;
168 }
169
170 strcpy( tmp, name ) ;
171
172 /* first check for exact match */
173 if ( !strcmp( p->name , tmp ) )
174 {
175 return(p) ;
176 }
177
178 t1 = NULL ;
179 if ((t1 = index(tmp,'%'))!= NULL ) *t1 = '\0' ;
180
181 if ( p->ntl > 1 )
182 {
183 if (( t2 = rindex( tmp , '_' )) != NULL )
184 {
185 /* be sure it really is an integer that follows the _ and that */
186 /* that is that is the last character */
187 if ((*(t2+1) >= '0' && *(t2+1) <= '9') && *(t2+2)=='\0') *t2 = '\0' ;
188 }
189 }
190
191 /* also allow _tend */
192 if (( t2 = rindex( tmp , '_' )) != NULL ) {
193 if (!strcmp(t2,"_tend")) *t2 = '\0' ;
194 }
195
196 /* also allow _tend */
197 if (( t2 = rindex( tmp , '_' )) != NULL ) {
198 if (!strcmp(t2,"_old")) *t2 = '\0' ;
199 }
200
201 if ( !strcmp( p->name , tmp ) )
202 {
203 if ( t1 != NULL ) return( get_entry_r( t1+1 , use , p->type->fields ) ) ;
204 return(p) ;
205 }
206 }
207 return(NULL) ;
208 }
209
210 node_t *
211 get_dimnode_for_coord ( node_t * node , int coord_axis )
212 {
213 int i ;
214 if ( node == NULL ) return(NULL) ;
215 for ( i = 0 ; i < node->ndims ; i++ )
216 {
217 if ( node->dims[i] == NULL ) continue ;
218 if ( node->dims[i]->coord_axis == coord_axis )
219 {
220 return(node->dims[i]) ;
221 }
222 }
223 return(NULL) ;
224 }
225
226 int
227 get_index_for_coord ( node_t * node , int coord_axis )
228 {
229 int i ;
230 if ( node == NULL ) return( -1 ) ;
231 for ( i = 0 ; i < node->ndims ; i++ )
232 {
233 if ( node->dims[i] == NULL ) continue ;
234 if ( node->dims[i]->coord_axis == coord_axis )
235 {
236 return(i) ;
237 }
238 }
239 return(-1) ;
240 }
241
242
243 char *
244 set_mem_order( node_t * node , char * str , int n )
245 {
246 int i ;
247 node_t * p ;
248
249 if ( str == NULL || node == NULL ) return(NULL) ;
250 strcpy(str,"") ;
251 if ( node->boundary_array )
252 {
253 strcpy(str, "C") ; /* if this is called for a boundary array, just give it a */
254 /* "reasonable" value and move on. */
255 }
256 else
257 {
258 if ( node->ndims <= 0 )
259 {
260 strcat(str,"0") ; return(str) ;
261 }
262 for ( i = 0 ; i < node->ndims && i < n ; i++ )
263 {
264 p = node->dims[i] ;
265 switch( p->coord_axis )
266 {
267 case(COORD_X) : strcat(str,"X") ; break ;
268 case(COORD_Y) : strcat(str,"Y") ; break ;
269 case(COORD_Z) : strcat(str,"Z") ; break ;
270 case(COORD_C) : strcat(str,"C") ; break ;
271 default : break ;
272 }
273 }
274 }
275 return(str) ;
276 }