tools/type.c

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