gen_mod_state_descr.c

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