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