tools/gen_scalar_indices.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 #include "protos.h"
  12 #include "registry.h"
  13 #include "data.h"
  14
  15 #define NULLCHARPTR   (char *) 0
  16
  17 int
  18 gen_scalar_indices ( char * dirname )
  19 {
  20   FILE * fp, *fp5[26] ;
  21   char  fname[NAMELEN], fname5[NAMELEN] ;
  22   char * fn = "scalar_indices.inc" ;
  23   char * fn2 = "scalar_tables.inc" ;
  24   char * fn3 = "scalar_tables_init.inc" ;
  25   char * fn4 = "scalar_indices_init.inc" ;
  26   int i ;
  27
  28   char fn5[26][NAMELEN] ;
  29
  30   strcpy( fname, fn ) ;
  31   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
  32   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  33   print_warning(fp,fname) ;
  34
  35  /* hashing to make the run time function being generated faster */
  36   for ( i = 0 ; i < 26 ; i++ )
  37   {
  38     sprintf(fn5[i],"in_use_for_config_%c.inc",'a'+i) ;
  39     strcpy( fname5, fn5[i] ) ;
  40     if ( strlen(dirname) > 0 ) { sprintf(fname5,"%s/%s",dirname,fn5[i]) ; }
  41     if ((fp5[i] = fopen( fname5 , "w" )) == NULL ) return(1) ;
  42     print_warning(fp5[i],fname5) ;
  43   }
  44   gen_scalar_indices1 ( fp, fp5 ) ;
  45   close_the_file( fp ) ;
  46   for ( i = 0 ; i < 26 ; i++ )
  47   {
  48     close_the_file( fp5[i] ) ;
  49   }
  50
  51   strcpy( fname, fn2 ) ;
  52   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn2) ; }
  53   if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; }
  54   print_warning(fp,fname) ;
  55   gen_scalar_tables ( fp ) ;
  56   close_the_file( fp ) ;
  57
  58   strcpy( fname, fn3 ) ;
  59   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn3) ; }
  60   if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; }
  61   print_warning(fp,fname) ;
  62   gen_scalar_tables_init ( fp ) ;
  63   close_the_file( fp ) ;
  64
  65   strcpy( fname, fn4 ) ;
  66   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn4) ; }
  67   if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; }
  68   print_warning(fp,fname) ;
  69   gen_scalar_indices_init ( fp ) ;
  70   close_the_file( fp ) ;
  71
  72   return(0) ;
  73 }
  74
  75 int
  76 gen_scalar_tables ( FILE * fp )
  77 {
  78   node_t * p ;
  79   for ( p = FourD ; p != NULL ; p=p->next4d )
  80   {
  81     fprintf(fp,"  INTEGER, TARGET :: %s_index_table( param_num_%s, max_domains )\n",p->name,p->name )  ;
  82     fprintf(fp,"  INTEGER, TARGET :: %s_num_table( max_domains )\n", p->name ) ;
  83     fprintf(fp,"  TYPE(streamrec), TARGET :: %s_streams_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
  84     fprintf(fp,"  LOGICAL, TARGET :: %s_boundary_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
  85     fprintf(fp,"  CHARACTER*256, TARGET :: %s_dname_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
  86     fprintf(fp,"  CHARACTER*256, TARGET :: %s_desc_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
  87     fprintf(fp,"  CHARACTER*256, TARGET :: %s_units_table( max_domains, param_num_%s )\n", p->name,p->name ) ;
  88   }
  89   return(0) ;
  90 }
  91
  92 int
  93 gen_scalar_tables_init ( FILE * fp )
  94 {
  95   node_t * p ;
  96   for ( p = FourD ; p != NULL ; p=p->next4d )
  97   {
  98     fprintf(fp,"  %s_num_table( j ) = 1\n",p->name )  ;
  99   }
 100   return(0) ;
 101 }
 102
 103 int
 104 gen_scalar_indices_init ( FILE * fp )
 105 {
 106   node_t * p ;
 107   for ( p = FourD ; p != NULL ; p=p->next4d )
 108   {
 109     fprintf(fp,"  num_%s = %s_num_table( idomain )\n",p->name,p->name )  ;
 110   }
 111   return(0) ;
 112 }
 113
 114 int
 115 gen_scalar_indices1 ( FILE * fp, FILE ** fp2 )
 116 {
 117   node_t * p, * memb , * pkg, * rconfig, * fourd, *x ;
 118   char * c , *pos1, *pos2 ;
 119   char assoc_namelist_var[NAMELEN], assoc_namelist_choice[NAMELEN], assoc_4d[NAMELEN_LONG], fname[NAMELEN_LONG] ;
 120   char fname2[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ;
 121   char scalars_str[NAMELEN_LONG] ;
 122   char * scalars ;
 123   int i ;
 124
 125 /*  for ( p = FourD ; p != NULL ; p = p->next )
 126    { for ( memb = p->members ; memb != NULL ; memb = memb->next )
 127       { if ( strcmp(memb->name,"-") ) fprintf(fp,"  P_%s = 1 ; F_%s = .FALSE. \n", memb->name, memb->name ) ; } } */
 128
 129   for ( p = FourD ; p != NULL ; p = p->next ) {
 130     if( strncmp( p->name,"irr_diag",8 ) ) {
 131       for ( memb = p->members ; memb != NULL ; memb = memb->next )
 132         if ( strcmp(memb->name,"-") ) fprintf(fp,"  P_%s = 1 ; F_%s = .FALSE. \n", memb->name, memb->name ) ;
 133     }
 134   }
 135
 136   fprintf(stderr,"Packages in gen_scalar_indices1\n");
 137
 138   for ( pkg = Packages ; pkg != NULL ; pkg = pkg->next )
 139   {
 140     strcpy( assoc_namelist_var , pkg->pkg_assoc ) ;
 141
 142     if ((c = index( assoc_namelist_var , '=' ))==NULL) continue ;
 143     *c = '\0' ; c += 2 ;
 144     strcpy( assoc_namelist_choice , c ) ;
 145     if ((rconfig=get_rconfig_entry ( assoc_namelist_var )) == NULL )
 146      { fprintf(stderr,
 147        "WARNING: There is no associated namelist variable %s\n",
 148         assoc_namelist_var) ; continue ; }
 149     fprintf(fp,"  IF (model_config_rec%%%s%s==%s)THEN\n",
 150                  assoc_namelist_var,
 151                  (atoi(rconfig->nentries)!=1)?"(idomain)":"",  /* a little tricky; atoi of nentries will be '0' for a string like max_domains */
 152                  assoc_namelist_choice) ;
 153     strcpy(scalars_str,pkg->pkg_4dscalars) ;
 154
 155
 156     if ((scalars = strtok_rentr(scalars_str,";", &pos1)) != NULL)
 157     {
 158       while ( scalars != NULL ) {
 159
 160         if ((c = strtok_rentr(scalars,":",&pos2)) != NULL) strcpy(assoc_4d,c) ; /* get name of associated 4d array */
 161         if (strcmp(c,"-")) {
 162           if ( (fourd=get_4d_entry( assoc_4d )) != NULL || !strcmp( assoc_4d, "state" ) ) {
 163             for ( c = strtok_rentr(NULL,",",&pos2) ; c != NULL ; c = strtok_rentr(NULL,",",&pos2) )
 164             {
 165               if ( fourd != NULL && ( ( x = get_entry_r( c , NULL, fourd->members )) != NULL ) ) {
 166                 fprintf(fp,"   IF ( %s_index_table( PARAM_%s , idomain ) .lt. 1 ) THEN\n",assoc_4d,c) ;
 167                 fprintf(fp,"     %s_num_table(idomain) = %s_num_table(idomain) + 1\n",assoc_4d,assoc_4d) ;
 168                 fprintf(fp,"     P_%s = %s_num_table(idomain)\n",c,assoc_4d) ;
 169                 fprintf(fp,"     %s_index_table( PARAM_%s , idomain ) = P_%s\n",assoc_4d,c,c) ;
 170                 fprintf(fp,"   ELSE\n") ;
 171                 fprintf(fp,"     P_%s = %s_index_table( PARAM_%s , idomain )\n",c,assoc_4d,c)  ;
 172                 fprintf(fp,"   END IF\n") ;
 173                 {
 174                   char fourd_bnd[NAMELEN] ;
 175                   /* check for the existence of a fourd boundary array associated with this 4D array */
 176                   /* set io_mask accordingly for gen_wrf_io to know that it should generate i/o for _b and _bt */
 177                   /* arrays */
 178                   sprintf(fourd_bnd,"%s_b",assoc_4d) ;
 179                   if ( get_entry_r( fourd_bnd, NULL, Domain.fields) != NULL ) {
 180                      x->boundary = 1 ;
 181                   }
 182                 }
 183                 fprintf(fp,"   %s_boundary_table( idomain, P_%s ) = %s\n",assoc_4d,c, (x->boundary==1)?".TRUE.":".FALSE." ) ;
 184                 fprintf(fp,"   %s_dname_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->dname) ;
 185                 fprintf(fp,"   %s_desc_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->descrip) ;
 186                 fprintf(fp,"   %s_units_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->units) ;
 187
 188
 189                 for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
 190                   fprintf(fp,"   %s_streams_table( idomain, P_%s )%%stream(%d) = %d ! %08x \n",assoc_4d,c,
 191                                                                           i+1,x->io_mask[i],x->io_mask[i] ) ;
 192                 }
 193
 194                 fprintf(fp,"   F_%s = .TRUE.\n",c) ;
 195               } else if ((p = get_entry_r( c , NULL, Domain.fields )) != NULL ) {
 196                 int tag, fo  ;
 197                 for ( tag = 1 ; tag <= p->ntl ; tag++ )
 198                   {
 199                   if ( !strcmp ( p->use , "_4d_bdy_array_") ) {
 200                     strcpy(fname,p->name) ;
 201                   } else {
 202                     strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
 203                   }
 204                   if ( strchr (c, '%') != NULLCHARPTR ) {
 205                     strcpy(fname2,c) ;
 206                   } else {
 207                     sprintf(tmp1,"%s_tend",p->name) ;
 208                     sprintf(tmp2,"%s_old",p->name) ;
 209                     if ( !strcmp(c, tmp1) ) {
 210                       strcpy(fname2,tmp1) ;
 211                     } else if ( !strcmp(c, tmp2) ) {
 212                       strcpy(fname2,tmp2) ;
 213                     } else {
 214                       strcpy(fname2,fname) ;
 215                     }
 216                   }
 217
 218                   make_lower_case(fname2)  ;
 219
 220                   fo = fname2[0]-'a' ;
 221
 222                   fprintf(fp2[fo],"IF(TRIM(vname).EQ.'%s')THEN\n",fname2) ;
 223                   fprintf(fp2[fo],"  IF(uses.EQ.0)THEN\n");
 224                   fprintf(fp2[fo],"    in_use = model_config_rec%%%s%s.EQ.%s\n",assoc_namelist_var,(atoi(rconfig->nentries)!=1)?"(id)":"",assoc_namelist_choice) ;
 225                   fprintf(fp2[fo],"    uses = 1\n") ;
 226                   fprintf(fp2[fo],"  ELSE\n") ;
 227                   fprintf(fp2[fo],"    in_use = in_use.OR.model_config_rec%%%s%s.EQ.%s\n",assoc_namelist_var,(atoi(rconfig->nentries)!=1)?"(id)":"",assoc_namelist_choice) ;
 228                   fprintf(fp2[fo],"  ENDIF\n") ;
 229                   fprintf(fp2[fo],"ENDIF\n") ;
 230
 231                 }
 232               } else {
 233                 fprintf(stderr, "WARNING: %s is not a member of 4D array %s\n",c,assoc_4d);continue;
 234               }
 235             }
 236           } else {
 237             fprintf(stderr, "WARNING: There is no 4D array named %s\n",assoc_4d);continue ;
 238           }
 239         }
 240
 241         scalars = strtok_rentr(NULL,";", &pos1) ;
 242
 243       }
 244     }
 245
 246     fprintf(fp,"  END IF\n") ;
 247   }
 248
 249   return(0) ;
 250 }
 251
 252