wrfv2_fire/tools/type.c

   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   return(NULL) ;
 140 }
 141
 142 /* this gets the entry for the node even if it           */
 143 /* is a derived data structure; does this by following   */
 144 /* the fully specified f90 reference.  For example:      */
 145 /* "xa%f" for the field of derived type xa.              */
 146 /* note it will also take care to ignore the _1 or _2    */
 147 /* suffixes from variables that have ntl > 1             */
 148 /* 11/10/2001 -- added use field; if the entry has a use */
 149 /* that starts with "dyn_" and use doesn't correspond to */
 150 /* that, skip that entry and continue                    */
 151
 152 node_t *
 153 get_entry_r ( char * name , char * use , node_t * node )
 154 {
 155   node_t *p ;
 156   char tmp[NAMELEN], *t1, *t2 ;
 157
 158   if ( name == NULL ) return (NULL)  ;
 159   if ( node == NULL ) return (NULL)  ;
 160
 161   for ( p = node ; p != NULL ; p = p->next )
 162   {
 163     strcpy( tmp, name ) ;
 164
 165     /* first check for exact match */
 166     if ( !strcmp( p->name , tmp ) )
 167     {
 168       return(p) ;
 169     }
 170
 171     t1 = NULL ;
 172     if ((t1 = index(tmp,'%'))!= NULL ) *t1 = '\0' ;
 173
 174     if ( p->ntl > 1 )
 175     {
 176       if (( t2 = rindex( tmp , '_' )) != NULL )
 177       {
 178          /* be sure it really is an integer that follows the _ and that */
 179          /* that is that is the last character                          */
 180          if ((*(t2+1) >= '0' && *(t2+1) <= '9') && *(t2+2)=='\0') *t2 = '\0' ;
 181       }
 182     }
 183
 184     /* also allow _tend */
 185     if (( t2 = rindex( tmp , '_' )) != NULL ) {
 186          if (!strcmp(t2,"_tend")) *t2 = '\0' ;
 187     }
 188
 189     /* also allow _tend */
 190     if (( t2 = rindex( tmp , '_' )) != NULL ) {
 191          if (!strcmp(t2,"_old")) *t2 = '\0' ;
 192     }
 193
 194     if ( !strcmp( p->name , tmp ) )
 195     {
 196       if ( t1 != NULL ) return( get_entry_r( t1+1 , use , p->type->fields ) ) ;
 197       return(p) ;
 198     }
 199   }
 200   return(NULL) ;
 201 }
 202
 203 node_t *
 204 get_dimnode_for_coord ( node_t * node , int coord_axis )
 205 {
 206   int i ;
 207   if ( node == NULL ) return(NULL) ;
 208   for ( i = 0 ; i < node->ndims ; i++ )
 209   {
 210     if ( node->dims[i] == NULL ) continue ;
 211     if ( node->dims[i]->coord_axis == coord_axis )
 212     {
 213       return(node->dims[i]) ;
 214     }
 215   }
 216   return(NULL) ;
 217 }
 218
 219 int
 220 get_index_for_coord ( node_t * node , int coord_axis )
 221 {
 222   int i ;
 223   if ( node == NULL ) return( -1 ) ;
 224   for ( i = 0 ; i < node->ndims ; i++ )
 225   {
 226     if ( node->dims[i] == NULL ) continue ;
 227     if ( node->dims[i]->coord_axis == coord_axis )
 228     {
 229       return(i) ;
 230     }
 231   }
 232   return(-1) ;
 233 }
 234
 235
 236 char *
 237 set_mem_order( node_t * node , char * str , int n )
 238 {
 239   int i ;
 240   node_t * p ;
 241
 242   if ( str == NULL || node == NULL ) return(NULL) ;
 243   strcpy(str,"") ;
 244   if ( node->boundary_array )
 245   {
 246      strcpy(str, "C") ;  /* if this is called for a boundary array, just give it a   */
 247                          /* "reasonable" value and move on.                          */
 248   }
 249   else
 250   {
 251     if ( node->ndims <= 0 )
 252     {
 253       strcat(str,"0") ; return(str) ;
 254     }
 255     for ( i = 0 ; i < node->ndims && i < n  ; i++ )
 256     {
 257       p = node->dims[i] ;
 258       switch( p->coord_axis )
 259       {
 260       case(COORD_X) : strcat(str,"X") ; break ;
 261       case(COORD_Y) : strcat(str,"Y") ; break ;
 262       case(COORD_Z) : strcat(str,"Z") ; break ;
 263       case(COORD_C) : strcat(str,"C") ; break ;
 264       default : break ;
 265       }
 266     }
 267   }
 268   return(str) ;
 269 }