tools/gen_mod_state_descr.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 int
  16 gen_module_state_description ( char * dirname )
  17 {
  18   FILE * fp ;
  19   char  fname[NAMELEN] ;
  20   char * fn = "module_state_description.F" ;
  21
  22   strcpy( fname, fn ) ;
  23   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
  24   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  25   print_warning(fp,fname) ;
  26   gen_module_state_description1 ( fp , &Domain ) ;
  27   close_the_file( fp ) ;
  28   return(0) ;
  29 }
  30
  31 int
  32 gen_module_state_description1 ( FILE * fp , node_t * node )
  33 {
  34   node_t * p, * q ;
  35   char * x ;
  36
  37   if ( node == NULL ) return(1) ;
  38
  39   fprintf(fp,"MODULE module_state_description\n") ;
  40
  41   fprintf(fp,"  ! package constants\n") ;
  42   for ( p = Packages ; p != NULL ; p = p->next )
  43   {
  44     x=index(p->pkg_assoc,'=') ; x+=2 ;
  45     fprintf(fp,"  INTEGER, PARAMETER :: %s = %s\n",p->name,x) ;
  46   }
  47   fprintf(fp,"  ! 4D array constants\n") ;
  48   for ( p = FourD ; p != NULL ; p=p->next4d )
  49   {
  50     int c1 ;
  51     for( q = p->members, c1=0 ; q != NULL ; q=q->next, c1++ )
  52     {
  53       if( strncmp( p->name,"irr_diag",8 ) && strcmp(q->name,"-" ) )
  54       {
  55         fprintf(fp,"  INTEGER, PARAMETER :: PARAM_%s = %d\n",q->name,c1) ;
  56         fprintf(fp,"  INTEGER            ::     P_%s = 1\n",q->name) ;
  57         fprintf(fp,"  LOGICAL            ::     F_%s = .FALSE.\n",q->name) ;
  58       }
  59     }
  60     fprintf(fp,"  INTEGER, PARAMETER :: PARAM_NUM_%s = %d\n",p->name,c1) ;
  61     fprintf(fp,"  INTEGER            ::       NUM_%s = 1\n",p->name) ;
  62   }
  63   fprintf(fp,"  INTEGER, PARAMETER :: %-30s = %d\n", "P_XSB",1 ) ;
  64   fprintf(fp,"  INTEGER, PARAMETER :: %-30s = %d\n", "P_XEB",2 ) ;
  65   fprintf(fp,"  INTEGER, PARAMETER :: %-30s = %d\n", "P_YSB",3 ) ;
  66   fprintf(fp,"  INTEGER, PARAMETER :: %-30s = %d\n", "P_YEB",4 ) ;
  67
  68   fprintf(fp,"  INTEGER, PARAMETER :: NUM_TIME_LEVELS = %d\n", max_time_level ) ;
  69   fprintf(fp,"  INTEGER , PARAMETER :: PARAM_FIRST_SCALAR = 2\n" ) ;
  70
  71   fprintf(fp,"CONTAINS\n" ) ;
  72   fprintf(fp,"SUBROUTINE init_module_state_description\n" ) ;
  73   fprintf(fp,"END SUBROUTINE init_module_state_description\n" ) ;
  74   fprintf(fp,"END MODULE module_state_description\n") ;
  75
  76   return(0) ;
  77 }
  78