wrfv2_fire/tools/gen_config.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3
   4 #include "protos.h"
   5 #include "registry.h"
   6 #include "data.h"
   7 #include <string.h>
   8 #ifndef _WIN32
   9 # include <strings.h>
  10 #endif
  11 #include "sym.h"
  12
  13 int
  14 gen_namelist_defines ( char * dirname , int sw_dimension )
  15 {
  16   FILE * fp ;
  17   char  fname[NAMELEN] ;
  18   char  fn[NAMELEN] ;
  19   node_t *p ;
  20
  21   sprintf( fn, "namelist_defines%s.inc", sw_dimension?"":"2" ) ;
  22   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
  23   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  24   print_warning(fp,fname) ;
  25
  26   fprintf(fp,"integer    :: first_item_in_struct\n") ;
  27   for ( p = Domain.fields ; p != NULL ; p = p-> next )
  28   {
  29     if ( p->node_kind & RCONFIG )
  30     {
  31       if ( sw_dimension )
  32       {
  33         if      ( !strcmp( p->nentries, "1" ) )
  34           fprintf(fp,"%s :: %s\n",p->type->name ,p->name) ;
  35         else if (  strcmp( p->nentries, "-" ) )  /* if not equal to "-" */
  36           fprintf(fp,"%s , DIMENSION(%s) :: %s\n",p->type->name ,p->nentries,p->name) ;
  37       }
  38       else
  39       {
  40         fprintf(fp,"%s :: %s\n",p->type->name ,p->name) ;
  41       }
  42     }
  43   }
  44   fprintf(fp,"integer    :: last_item_in_struct\n") ;
  45
  46   close_the_file( fp ) ;
  47   return(0) ;
  48 }
  49
  50 int
  51 gen_namelist_defaults ( char * dirname )
  52 {
  53   FILE * fp ;
  54   char  fname[NAMELEN] ;
  55   char  *fn = "namelist_defaults.inc" ;
  56   node_t *p ;
  57
  58   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
  59   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  60   print_warning(fp,fname) ;
  61
  62   for ( p = Domain.fields ; p != NULL ; p = p-> next )
  63   {
  64     if ( p->node_kind & RCONFIG && strcmp(p->dflt,"-") && strcmp(p->dflt,""))
  65     {
  66       if ( !strncmp ( p->type->name , "character", 9 ) ) {
  67         fprintf(fp,"%s = \"%s\"\n",p->name ,p->dflt) ;
  68       } else {
  69         fprintf(fp,"%s = %s\n",p->name ,p->dflt) ;
  70       }
  71     }
  72   }
  73
  74   close_the_file( fp ) ;
  75   return(0) ;
  76 }
  77
  78
  79 int
  80 gen_namelist_statements ( char * dirname )
  81 {
  82   FILE * fp ;
  83   char  fname[NAMELEN] ;
  84   char * fn = "namelist_statements.inc" ;
  85   char  howset[NAMELEN] ;
  86   char *p1, *p2 ;
  87   node_t *p ;
  88
  89   strcpy( fname, fn ) ;
  90   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
  91   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  92   print_warning(fp,fname) ;
  93
  94   for ( p = Domain.fields ; p != NULL ; p = p-> next )
  95   {
  96     if ( p->node_kind & RCONFIG )
  97     {
  98       strcpy(howset,p->howset) ;
  99       if (( p1 = strtok(howset,",")) != NULL )
 100       {
 101         p2 = strtok(NULL,",") ;
 102         if ( !strcmp(p1,"namelist") )
 103         {
 104           if ( p2 == NULL )
 105           {
 106             fprintf(stderr,
 107             "Warning: no namelist section specified for nl %s\n",p->name) ;
 108             continue ;
 109           }
 110           fprintf(fp,"NAMELIST /%s/ %s\n",p2,p->name) ;
 111         }
 112       }
 113     }
 114   }
 115
 116   close_the_file( fp ) ;
 117   return(0) ;
 118 }
 119
 120 int
 121 gen_namelist_script ( char * dirname )
 122 {
 123   FILE * fp ;
 124   char  fname[NAMELEN] ;
 125   char  *fn = "namelist_script.inc" ;
 126   node_t *p,*q ;
 127   char *p1, *p2, *p3, *p4 ;
 128   char *i;
 129   char  howset1[NAMELEN] ;
 130   char  howset2[NAMELEN] ;
 131
 132   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 133   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 134
 135   sym_forget() ;
 136
 137   fprintf(fp,"# Machine generated, do not edit\n\n") ;
 138   fprintf(fp,"FILE=${1:-namelist.input}\n\n");
 139
 140   for ( p = Domain.fields ; p != NULL ; p = p-> next )
 141   {
 142     if ( p->node_kind & RCONFIG )
 143     {
 144       strcpy(howset1,p->howset) ;
 145       p1 = strtok(howset1,",") ;
 146       p2 = strtok(NULL,",") ;
 147       if ( !strcmp(p1,"namelist") ) {
 148         if ( p2 == NULL ) {
 149           fprintf(stderr,
 150           "Warning: no namelist section specified for nl %s\n",p->name) ;
 151           continue ;
 152         }
 153         if (sym_get( p2 ) == NULL) { /* not in table yet */
 154           fprintf(fp,"echo \\&%s >> $FILE\n",p2) ;
 155           for ( q = Domain.fields ; q != NULL ; q = q-> next ) {
 156             if ( q->node_kind & RCONFIG) {
 157               strcpy(howset2,q->howset) ;
 158               p3 = strtok(howset2,",") ;
 159               p4 = strtok(NULL,",") ;
 160               if ( p4 == NULL ) {
 161                 continue ;
 162               }
 163
 164               if ( !strcmp(p2,p4)) {
 165                 fprintf(fp,"if test ! -z \"$NL_") ;
 166                 for (i=q->name; *i!='\0'; i++) {
 167                   fputc(toupper(*i),fp);
 168                 }
 169                 if ( !strncmp(q->type->name,"character",9)) {
 170                    fprintf(fp,"\"; then echo \"%s=\\\"${NL_",q->name) ;
 171                    for (i=q->name; *i!='\0'; i++) {
 172                      fputc(toupper(*i),fp);
 173                    }
 174                    fprintf(fp,"}\\\",\"") ;
 175                 } else {
 176                   fprintf(fp,"\"; then echo \"%s=${NL_",q->name) ;
 177                   for (i=q->name; *i!='\0'; i++) {
 178                     fputc(toupper(*i),fp);
 179                   }
 180                   fprintf(fp,"},\"") ;
 181                 }
 182
 183                 fprintf(fp," >> $FILE;fi\n") ;
 184               }
 185
 186             }
 187           }
 188           fprintf(fp,"echo / >> $FILE\n") ;
 189           sym_add(p2) ;
 190         }
 191       }
 192     }
 193   }
 194
 195   fprintf(fp,"echo \\&namelist_quilt >> $FILE\n");
 196   fprintf(fp,"if test ! -z \"$NL_NIO_TASKS_PER_GROUP\"; then echo \"nio_tasks_per_group=${NL_NIO_TASKS_PER_GROUP},\" >> $FILE;fi\n");
 197   fprintf(fp,"if test ! -z \"$NL_NIO_GROUPS\"; then echo \"nio_groups=${NL_NIO_GROUPS},\" >> $FILE;fi\n");
 198   fprintf(fp,"echo / >> $FILE\n");
 199
 200   fclose( fp ) ;
 201   return(0) ;
 202 }
 203
 204
 205 int
 206 gen_get_nl_config ( char * dirname )
 207 {
 208   FILE * fp ;
 209   char  fname[NAMELEN] ;
 210   char * fn = "nl_config.inc" ;
 211   char * gs, * intnt ;
 212   char  howset[NAMELEN] ;
 213   node_t *p ;
 214   int sw ;
 215   int num_rconfigs = 0 ;
 216   int i, fraction, j ;
 217 #define FRAC 8
 218
 219   strcpy( fname, fn ) ;
 220   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 221   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 222   print_warning(fp,fname) ;
 223
 224   for ( p = Domain.fields ; p != NULL ; p = p-> next ) { if ( p->node_kind & RCONFIG ) { num_rconfigs++ ; } }  /* howmany deez guys? */
 225
 226   for ( sw = 0 ; sw < 2 ; sw++ ) {
 227
 228   if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; }
 229
 230   fprintf(fp,"#ifdef NL_%s_ROUTINES\n",gs) ;
 231
 232   for ( fraction = 0, j=0 ; fraction < num_rconfigs ; fraction += ((num_rconfigs+1)/FRAC+1), j++ ) { /* break the files in pieces
 233                                                                                                     so we don't kill the
 234                                                                                                     compilers as much */
 235   fprintf(fp,"#if (NNN == %d)\n",j) ;
 236
 237   for ( p = Domain.fields, i = -1 ; p != NULL ; p = p-> next )
 238   {
 239     if ( p->node_kind & RCONFIG ) {
 240        i++ ;
 241     if ( (i >= fraction) && (i < fraction + (num_rconfigs+1)/FRAC+1) )
 242     {
 243       strcpy(howset,p->howset) ;
 244       fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ;
 245       if ( sw_fort_kludge ) {
 246         fprintf(fp,"  USE module_configure, ONLY : model_config_rec \n") ;
 247       }
 248       fprintf(fp,"  %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ;
 249       fprintf(fp,"  INTEGER id_id\n") ;
 250       if ( ! sw_fort_kludge ) fprintf(fp,"  CHARACTER*80 emess\n") ;
 251       if ( sw == 0 ) /* get */
 252       {
 253         if ( !strcmp( p->nentries, "1" )) {
 254           if ( ! sw_fort_kludge ) {
 255             fprintf(fp,"  IF ( id_id .NE. 1 ) THEN\n") ;
 256             fprintf(fp,"    call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
 257                             gs,p->name, p->name ) ;
 258             fprintf(fp,"  ENDIF\n" ) ;
 259           }
 260           if ( !strncmp(p->type->name,"character",9)) {
 261             fprintf(fp,"  %s = trim(model_config_rec%%%s)\n",p->name,p->name) ;
 262           }else{
 263             fprintf(fp,"  %s = model_config_rec%%%s\n",p->name,p->name) ;
 264           }
 265         } else {
 266           if ( ! sw_fort_kludge ) {
 267             if        ( !strcmp( p->nentries, "max_domains" )) {
 268               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
 269               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
 270             } else if ( !strcmp( p->nentries, "max_moves" )) {
 271               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
 272               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
 273             } else if ( !strcmp( p->nentries, "max_eta" )) {
 274               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
 275               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
 276             } else if ( !strcmp( p->nentries, "max_outer_iterations" )) {
 277               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_outer_iterations ) THEN\n") ;
 278               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eps number: ',id_id\n",gs,p->name) ;
 279             } else if ( !strcmp( p->nentries, "max_instruments" )) {
 280               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_instruments ) THEN\n") ;
 281               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range instruments number: ',id_id\n",gs,p->name) ;
 282             } else {
 283               fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, max_eta, max_outer_iterations, or max_instruments \n") ;
 284             }
 285             fprintf(fp,"    CALL wrf_error_fatal(emess)\n") ;
 286             fprintf(fp,"  ENDIF\n" ) ;
 287           }
 288           fprintf(fp,"  %s = model_config_rec%%%s(id_id)\n",p->name,p->name) ;
 289         }
 290       }
 291       else   /* set */
 292       {
 293         if ( !strcmp( p->nentries, "1" )) {
 294           if ( ! sw_fort_kludge ) {
 295             fprintf(fp,"  IF ( id_id .NE. 1 ) THEN\n") ;
 296             fprintf(fp,"    call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
 297                             gs,p->name, p->name ) ;
 298             fprintf(fp,"  ENDIF\n" ) ;
 299           }
 300           if ( !strncmp(p->type->name,"character",9)) {
 301             fprintf(fp,"  model_config_rec%%%s = trim(%s) \n",p->name,p->name) ;
 302           }else{
 303             fprintf(fp,"  model_config_rec%%%s = %s \n",p->name,p->name) ;
 304           }
 305         } else {
 306           if ( ! sw_fort_kludge ) {
 307             if        ( !strcmp( p->nentries, "max_domains" )) {
 308               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
 309               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
 310             } else if ( !strcmp( p->nentries, "max_moves" )) {
 311               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
 312               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
 313             } else if ( !strcmp( p->nentries, "max_eta" )) {
 314               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
 315               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
 316             } else if ( !strcmp( p->nentries, "max_outer_iterations" )) {
 317               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_outer_iterations ) THEN\n") ;
 318               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eps number: ',id_id\n",gs,p->name) ;
 319             } else if ( !strcmp( p->nentries, "max_instruments" )) {
 320               fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_instruments ) THEN\n") ;
 321               fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range instruments number: ',id_id\n",gs,p->name) ;
 322             } else {
 323               fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, max_eta, max_outer_iterations, or max_instruments \n") ;
 324             }
 325             fprintf(fp,"    CALL wrf_error_fatal(emess)\n") ;
 326             fprintf(fp,"  ENDIF\n" ) ;
 327           }
 328           fprintf(fp,"  model_config_rec%%%s(id_id) = %s\n",p->name,p->name) ;
 329         }
 330       }
 331       fprintf(fp,"  RETURN\n") ;
 332       fprintf(fp,"END SUBROUTINE nl_%s_%s\n",gs,p->name ) ;
 333     }
 334     }
 335   }
 336   fprintf(fp,"#endif\n") ;
 337   } /* fraction */
 338   fprintf(fp,"#endif\n") ;
 339   }
 340   close_the_file( fp ) ;
 341   return(0) ;
 342 }
 343
 344 int
 345 gen_config_assigns ( char * dirname )
 346 {
 347   FILE * fp ;
 348   char  fname[NAMELEN] ;
 349   char * fn = "config_assigns.inc" ;
 350   char  tmp[NAMELEN] ;
 351   node_t *p ;
 352
 353   strcpy( fname, fn ) ;
 354   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 355   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 356   print_warning(fp,fname) ;
 357
 358   fprintf(fp,"! Contains config assign statements for module_domain.F.\n") ;
 359   fprintf(fp,"#ifndef SOURCE_RECORD\n") ;
 360   fprintf(fp,"#  define SOURCE_RECORD cfg%%\n") ;
 361   fprintf(fp,"#endif\n") ;
 362   fprintf(fp,"#ifndef SOURCE_REC_DEX\n") ;
 363   fprintf(fp,"#  define SOURCE_REC_DEX\n") ;
 364   fprintf(fp,"#endif\n") ;
 365   fprintf(fp,"#ifndef DEST_RECORD\n") ;
 366   fprintf(fp,"#  define DEST_RECORD new_grid%%\n") ;
 367   fprintf(fp,"#endif\n") ;
 368
 369   for ( p = Domain.fields ; p != NULL ; p = p-> next )
 370   {
 371     if ( p->node_kind & RCONFIG )
 372     {
 373       if ( !strcmp( p->nentries, "1" ))
 374         strcpy( tmp, "" ) ;
 375       else
 376         strcpy( tmp, "SOURCE_REC_DEX" ) ;
 377       fprintf(fp," DEST_RECORD %-26s = SOURCE_RECORD %s %s\n",p->name,p->name,tmp) ;
 378     }
 379   }
 380   close_the_file( fp ) ;
 381   return(0) ;
 382 }
 383
 384 int
 385 gen_config_reads ( char * dirname )
 386 {
 387   FILE * fp ;
 388   int i, n_nml ;
 389   char  fname[NAMELEN] ;
 390   char * fn = "config_reads.inc" ;
 391   FILE * fp2 ;
 392   char  fname2[NAMELEN] ;
 393   char * fn2 = "namelist_nametest.inc" ;
 394   char  howset[NAMELEN] ;
 395   char *p1, *p2 ;
 396   node_t *p ;
 397
 398   strcpy( fname, fn ) ;
 399   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 400   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 401   print_warning(fp,fname) ;
 402   strcpy( fname2, fn2 ) ;
 403   if ( strlen(dirname) > 0 ) { sprintf(fname2,"%s/%s",dirname,fn2) ; }
 404   if ((fp2 = fopen( fname2 , "w" )) == NULL ) return(1) ;
 405   print_warning(fp2,fname2) ;
 406
 407   fprintf(fp,"! Contains namelist statements for module_config.F.\n") ;
 408   fprintf(fp,"#ifndef NAMELIST_READ_UNIT\n") ;
 409   fprintf(fp,"#  define NAMELIST_READ_UNIT nml_read_unit\n") ;
 410   fprintf(fp,"#endif\n") ;
 411   fprintf(fp,"#ifndef NAMELIST_WRITE_UNIT\n") ;
 412   fprintf(fp,"#  define NAMELIST_WRITE_UNIT nml_write_unit\n") ;
 413   fprintf(fp,"#endif\n") ;
 414   fprintf(fp,"!\n") ;
 415
 416   fprintf(fp2,"! Contains tests for IF statement in wrf_alt_nml_obsolete in module_configure.F \n") ;
 417
 418   sym_forget() ;
 419
 420   /*
 421      Count how many namelists are defined in the registry
 422   */
 423   n_nml = 0 ;
 424   for ( p = Domain.fields ; p != NULL ; p = p-> next )
 425   {
 426     if ( p->node_kind & RCONFIG )
 427     {
 428       strcpy(howset,p->howset) ;
 429       p1 = strtok(howset,",") ;
 430       p2 = strtok(NULL,",") ;
 431       if ( !strcmp(p1,"namelist") )
 432       {
 433         if (sym_get( p2 ) == NULL)  /* not in table yet */
 434         {
 435           n_nml ++ ;
 436           sym_add(p2) ;
 437           fprintf(fp2,"& %s (TRIM(nml_name) .EQ. '%s') &\n",n_nml==1?"    ":".OR.",p2) ;
 438         }
 439       }
 440     }
 441   }
 442   fclose(fp2) ;
 443
 444   sym_forget() ;
 445
 446   fprintf(fp," nml_read_error = .FALSE.\n") ;
 447   fprintf(fp," NML_LOOP : DO i=1,%i\n", n_nml) ;
 448   fprintf(fp,"    REWIND ( UNIT = NAMELIST_READ_UNIT )\n") ;
 449   fprintf(fp,"    SELECT CASE ( i )\n") ;
 450   i = 1;
 451   for ( p = Domain.fields ; p != NULL ; p = p-> next )
 452   {
 453     if ( p->node_kind & RCONFIG )
 454     {
 455       strcpy(howset,p->howset) ;
 456       p1 = strtok(howset,",") ;
 457       p2 = strtok(NULL,",") ;
 458       if ( !strcmp(p1,"namelist") )
 459       {
 460         if ( p2 == NULL )
 461         {
 462           fprintf(stderr,
 463           "Warning: no namelist section specified for nl %s\n",p->name) ;
 464           continue ;
 465         }
 466         if (sym_get( p2 ) == NULL)  /* not in table yet */
 467         {
 468           fprintf(fp,"       CASE ( %i ) \n",i) ;
 469           fprintf(fp,"          nml_name = \"%s\"\n",p2) ;
 470           fprintf(fp,"          READ   ( UNIT = NAMELIST_READ_UNIT , NML = %s , ERR=9201, END=9202 )\n",p2) ;
 471           fprintf(fp,"#ifndef NO_NAMELIST_PRINT\n") ;
 472           fprintf(fp,"          WRITE ( UNIT = NAMELIST_WRITE_UNIT, NML = %s )\n",p2) ;
 473           fprintf(fp,"#endif\n") ;
 474           fprintf(fp,"          CYCLE NML_LOOP\n") ;
 475           i ++ ;
 476           sym_add(p2) ;
 477         }
 478       }
 479     }
 480   }
 481   fprintf(fp,"    END SELECT\n") ;
 482   fprintf(fp,"9201 CALL wrf_message(\"  ------ ERROR while reading namelist \"//TRIM(nml_name)//\" ------\")\n") ;
 483   fprintf(fp,"    nml_read_error = .TRUE.\n") ;
 484
 485   fprintf(fp,"    CALL wrf_alt_nml_obsolete(nml_read_unit, TRIM(nml_name))\n") ;
 486   fprintf(fp,"    CYCLE NML_LOOP\n") ;
 487   fprintf(fp,"9202 CALL wrf_message(\"Namelist \"//TRIM(nml_name)//\" not found in namelist.input.\"// & \n") ;
 488   fprintf(fp,"                      \" Using registry defaults for variables in \"//TRIM(nml_name))\n") ;
 489   fprintf(fp," END DO NML_LOOP\n") ;
 490   fprintf(fp," \n") ;
 491   fprintf(fp," IF ( nml_read_error ) CALL wrf_error_fatal(\"ERRORS while reading one or more namelists from namelist.input.\")\n") ;
 492
 493   close_the_file( fp ) ;
 494   return(0) ;
 495 }
 496