chem/KPP/kpp/kpp-2.1/src.org/code_f90.c

   1 /******************************************************************************
   2
   3   KPP - The Kinetic PreProcessor
   4         Builds simulation code for chemical kinetic systems
   5
   6   Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu
   7   Copyright (C) 1997-2005 Adrian Sandu
   8
   9   KPP is free software; you can redistribute it and/or modify it under the
  10   terms of the GNU General Public License as published by the Free Software
  11   Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the
  12   License, or (at your option) any later version.
  13
  14   KPP is distributed in the hope that it will be useful, but WITHOUT ANY
  15   WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  16   FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  17   details.
  18
  19   You should have received a copy of the GNU General Public License along
  20   with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or
  21   write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22   Boston, MA  02111-1307,  USA.
  23
  24   Adrian Sandu
  25   Computer Science Department
  26   Virginia Polytechnic Institute and State University
  27   Blacksburg, VA 24060
  28   E-mail: sandu@cs.vt.edu
  29
  30 ******************************************************************************/
  31
  32
  33 #include "gdata.h"
  34 #include "code.h"
  35 #include <string.h>
  36 #include <stdio.h>
  37
  38 #define MAX_LINE 120
  39
  40 char *F90_types[] = { "",                   /* VOID */
  41                     "INTEGER",            /* INT */
  42                     "REAL(kind=sp)",      /* FLOAT */
  43                     "REAL(kind=dp)",      /* DOUBLE */
  44                     "CHARACTER(LEN=12)",  /* STRING */
  45                     "CHARACTER(LEN=100)"  /* DOUBLESTRING */
  46                   };
  47
  48 /*************************************************************************************************/
  49 void F90_WriteElm( NODE * n )
  50 {
  51 ELEMENT *elm;
  52 char * name;
  53 char maxi[20];
  54 char maxj[20];
  55
  56   elm = n->elm;
  57   name = varTable[ elm->var ]->name;
  58
  59   switch( n->type ) {
  60     case CONST: bprintf("%g", elm->val.cnst);
  61                 break;
  62     case ELM:   bprintf("%s", name);
  63                 break;
  64     case VELM:  if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 );
  65                   else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name );
  66                 bprintf("%s(%s)", name, maxi );
  67                 break;
  68     case MELM:  if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 );
  69                   else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name );
  70                 if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 );
  71                   else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name );
  72                 bprintf("%s(%s,%s)", name, maxi, maxj );
  73                 break;
  74     case EELM:  bprintf("(%s)", elm->val.expr );
  75                 break;
  76   }
  77 }
  78
  79 /*************************************************************************************************/
  80 void F90_WriteSymbol( int op )
  81 {
  82   switch( op ) {
  83     case ADD:   bprintf("+");
  84                 AllowBreak();
  85                 break;
  86     case SUB:   bprintf("-");
  87                 AllowBreak();
  88                 break;
  89     case MUL:   bprintf("*");
  90                 AllowBreak();
  91                 break;
  92     case DIV:   bprintf("/");
  93                 AllowBreak();
  94                 break;
  95     case POW:   bprintf("power");
  96                 break;
  97     case O_PAREN: bprintf("(");
  98                 AllowBreak();
  99                 break;
 100     case C_PAREN: bprintf(")");
 101                 break;
 102     case NONE:
 103                 break;
 104   }
 105 }
 106
 107 /*************************************************************************************************/
 108 void F90_WriteAssign( char *ls, char *rs )
 109 {
 110 int start;
 111 int linelg;
 112 int i, j;
 113 int ifound, jfound;
 114 char c;
 115 int first;
 116 int crtident;
 117
 118 /* Max no of continuation lines in F90/F95 differs with compilers, but 39
 119                                should work for every compiler*/
 120 int number_of_lines = 1, MAX_NO_OF_LINES = 36;
 121
 122 /*  Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ','
 123                       0xad = '-' | 0xae ='.' | 0xaf = '/' */
 124 char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf;
 125
 126   crtident = 2 + ident * 2;
 127   bprintf("%*s%s = ", crtident, "", ls);
 128   start = strlen( ls ) + 2;
 129   linelg = 120 - crtident - start - 1; /* F90 max line length is 132 */
 130
 131   first = 1;
 132   while( strlen(rs) > linelg ) {
 133     ifound = 0; jfound = 0;
 134     if ( number_of_lines >= MAX_NO_OF_LINES ) {
 135      /* If a new line needs to be started.
 136           Note: the approach below will create erroneous code if the +/- is within a subexpression, e.g. for
 137           A*(B+C) one cannot start a new continuation line by splitting at the + sign */
 138      for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */
 139        if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) {
 140         jfound = 1; i=j; break;
 141         }
 142     }
 143     if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) {
 144      for( i=linelg; i>10; i-- ) /* split row here if operator or comma */
 145        if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) {
 146         ifound = 1; break;
 147         }
 148      if( i <= 10 ) {
 149        printf("\n Warning: double-check continuation lines for:\n   %s = %s\n",ls,rs);
 150        i = linelg;
 151      }
 152     }
 153     while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */
 154     while ( rs[i] == ',' ) i++;   /* put commas on the current row */
 155
 156     c = rs[i];
 157     rs[i] = 0;
 158
 159     if ( first ) { /* first line in a split row */
 160       bprintf("%s", rs );
 161       linelg++;
 162       first = 0;
 163     } else {/* continuation line in a split row - but not last line*/
 164       bprintf("&\n     %*s&%s", start, "", rs );
 165       if ( jfound ) {
 166          bprintf("\n%*s%s = %s", crtident, "", ls, ls);
 167          number_of_lines = 1;
 168          }
 169     }
 170     rs[i] = c;
 171     rs += i;  /* jump to the first not-yet-written character */
 172     number_of_lines++;
 173   }
 174
 175   if ( number_of_lines > MAX_NO_OF_LINES ) {
 176      printf("\n Warning: %d continuation lines for %s = ...",number_of_lines,ls);
 177      }
 178
 179   if ( first ) bprintf("%s\n", rs );  /* non-split row */
 180           else bprintf("&\n     %*s&%s\n", start, "", rs ); /* last line in a split row */
 181
 182
 183   FlushBuf();
 184 }
 185
 186
 187 /*************************************************************************************************/
 188 void F90_WriteComment( char *fmt, ... )
 189 {
 190 Va_list args;
 191 int n;
 192 char buf[ MAX_LINE ];
 193
 194   Va_start( args, fmt );
 195   vsprintf( buf, fmt, args );
 196   va_end( args );
 197   /* remove trailing spaces */
 198   /* taken from http://www.cs.bath.ac.uk/~pjw/NOTES/ansi_c/ch10-idioms.pdf */
 199   for (n= strlen(buf) - 1; n >= 0; n--)
 200     if (buf[n] != ' ') break;
 201   buf[n + 1]= '\0';
 202   bprintf( "! %s\n", buf );
 203   FlushBuf();
 204 }
 205
 206 /*************************************************************************************************/
 207 char * F90_Decl( int v )
 208 {
 209 static char buf[120];
 210 VARIABLE *var;
 211 char *baseType;
 212 char maxi[20];
 213 char maxj[20];
 214
 215   var = varTable[ v ];
 216   baseType = F90_types[ var->baseType ];
 217
 218   *buf = 0;
 219
 220   switch( var->type ) {
 221     case ELM:
 222                 sprintf( buf, "%s :: %s", baseType, var->name );
 223                 break;
 224     case VELM:
 225                 if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
 226                 /*  else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */
 227                 /*sprintf( buf, "%s, DIMENSION(%s) :: %s", baseType, maxi, var->name );*/
 228                 if( var->maxi == 0 ) sprintf( maxi, "%d", 1 );
 229                 /*  else sprintf( maxi, "%s", varTable[ -var->maxi ]->name);  */
 230                 if ( var->maxi < 0 ) {
 231                     if (varTable[ -var->maxi ]->value < 0)
 232                       sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
 233                     else
 234                       sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0?
 235                            1:varTable[-var->maxi]->value );
 236                 }
 237                 sprintf( buf, "%s :: %s(%s)", baseType, var->name, maxi );
 238                 break;
 239     case MELM:
 240                 if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
 241                 else {
 242                  if (varTable[ -var->maxi ]->value < 0)
 243                     sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
 244                  else
 245                     sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0?
 246                            1:varTable[-var->maxi]->value );
 247                 }
 248                 /*  else sprintf( maxi, "%s", varTable[ -var->maxi ]->name);  */
 249                 /* if( (var->maxi == 0) ||
 250                     ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
 251                   strcat( maxi, "+1"); */
 252                 if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj );
 253                 else {
 254                  if (varTable[ -var->maxj ]->value < 0)
 255                     sprintf( maxj, "%s", varTable[ -var->maxj ]->name );
 256                  else
 257                     sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0?
 258                            1:varTable[-var->maxj]->value );
 259                 }
 260                 /*  else sprintf( maxj, "%s", varTable[ -var->maxj ]->name);  */
 261                 /*if( (var->maxj == 0) ||
 262                     ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) )
 263                   strcat( maxj, "+1");*/
 264                 /*sprintf( buf, "%s, DIMENSION(%s,%s) :: %s",
 265                          baseType, maxi, maxj,var->name ); */
 266                 sprintf( buf, "%s :: %s(%s,%s)",
 267                          baseType, var->name, maxi, maxj );
 268                 break;
 269     default:
 270                 printf( "Can not declare type %d\n", var->type );
 271                 break;
 272   }
 273   return buf;
 274 }
 275
 276 /*************************************************************************************************/
 277 char * F90_DeclareData( int v, void * values, int n)
 278 {
 279 int i, j;
 280 int nlines;
 281 int split;
 282 static char buf[120];
 283 VARIABLE *var;
 284 int * ival;
 285 double * dval;
 286 char ** cval;
 287 char *baseType;
 288 char maxi[20];
 289 char maxj[20];
 290 int maxCols = MAX_COLS;
 291 char dsbuf[200];
 292
 293  int i_from, i_to;
 294  int isplit;
 295  int splitsize;
 296  int maxi_mod;
 297  int maxi_div;
 298
 299  char mynumber[30];
 300
 301   var = varTable[ v ];
 302   ival = (int*) values;
 303   dval = (double *) values;
 304   cval = (char **) values;
 305
 306   nlines = 1;
 307   split = 0;
 308   var -> maxi = max( n, 1 );
 309
 310   baseType = F90_types[ var->baseType ];
 311
 312   *buf = 0;
 313
 314   switch( var->type ) {
 315     case ELM:
 316             bprintf( "  %s :: %s = ", baseType, var->name );
 317                 switch ( var->baseType ) {
 318                   case INT: bprintf( "%d", *ival ); break;
 319                   case DOUBLE: bprintf( "%f", *dval); break;
 320                   case REAL: bprintf( "%lg", *dval ); break;
 321                   case STRING: bprintf( "'%3s'", *cval ); break;
 322                 }
 323                 break;
 324     case VELM:
 325       /* define maxCols here already and choose suitable splitsize */
 326       switch( var -> baseType ) {
 327       case INT:          maxCols =12; break;
 328       case DOUBLE:       maxCols = 5; break;
 329       case REAL:         maxCols = 5; break;
 330       case STRING:       maxCols = 3; break;
 331       case DOUBLESTRING: maxCols = 1; break;
 332       }
 333       splitsize = 30 * maxCols; /* elements = lines * columns */
 334       maxi_mod = var->maxi % splitsize;
 335       maxi_div = var->maxi / splitsize;
 336       /* correction if var->maxi is a multiple of splitsize */
 337       if ( (maxi_div>0) && (maxi_mod==0) ) {
 338         maxi_mod = splitsize;
 339         maxi_div--;
 340       }
 341       for ( isplit=0; isplit <= maxi_div; isplit++ ) {
 342         if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
 343         else sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
 344         if( (var->maxi == 0) ||
 345             ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
 346           strcat( maxi, "+1");
 347         bprintf( "  %s, " , baseType);
 348         if( n>0 ) bprintf( "PARAMETER, " ); /* if values are assigned now */
 349         if ( maxi_div==0 ) { /* define array in one piece */
 350           bprintf( "DIMENSION(%s) :: %s",
 351                    maxi, var->name) ;
 352         } else {/* define partial arrays */
 353           if ( isplit==maxi_div ) { /* last part has size maxi_mod */
 354             bprintf( "DIMENSION(%d) :: %s_%d",
 355                      maxi_mod, var->name, isplit) ;
 356           } else { /* all other parts have size splitsize */
 357             bprintf( "DIMENSION(%d) :: %s_%d",
 358                      splitsize, var->name, isplit) ;
 359           }
 360         }
 361         if( n<=0 ) break;
 362
 363         /* now list values */
 364         bprintf( " = (/ &\n     " );
 365         /*   if the array is defined in one piece, then the for loop will
 366                  go from 0 to n. Otherwise, there will be partial arrays from
 367                  i_from to i_to which are of size splitsize except for the
 368                  last one which is usually smaller and contains the rest */
 369         i_from = isplit * splitsize;
 370         i_to   = min(i_from+splitsize,n);
 371         for ( i=i_from; i < i_to; i++ ) {
 372           switch( var -> baseType ) {
 373           case INT:
 374             bprintf( "%3d", ival[i] ); break;
 375           case DOUBLE:
 376             /* bprintf( "%4f", dval[i] ); maxCols = 5; break; */
 377             sprintf(mynumber, "%12.6e_dp",dval[i]);
 378             /* mynumber[ strlen(mynumber)-4 ] = 'd'; */
 379             bprintf( "  %s", mynumber ); break;
 380           case REAL:
 381             bprintf( "%12.6e", dval[i] ); break;
 382           case STRING:
 383             bprintf( "'%-12s'", cval[i] ); break;
 384           case DOUBLESTRING:
 385             /* strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; */
 386             /* bprintf( "'%48s'", dsbuf ); break; */
 387             bprintf( "'%-100.100s'", cval[i] ); break;
 388           }
 389           if( i < i_to-1 ) {
 390             bprintf( "," );
 391             if( (i+1) % maxCols == 0 ) {
 392               bprintf( " &\n     " );
 393               nlines++;
 394             }
 395           }
 396         }
 397         bprintf( " /)\n" );
 398       }
 399
 400       /* combine the partial arrays */
 401       if ( maxi_div != 0 ) {
 402         bprintf( "  %s, PARAMETER, DIMENSION(%s) :: %s = (/&\n    ",
 403                  baseType, maxi, var->name) ;
 404         for ( isplit=0; isplit <= maxi_div; isplit++ ) {
 405           bprintf( "%s_%d", var->name, isplit) ;
 406           if( isplit < maxi_div ) { /* more parts will follow */
 407             bprintf( ", " );
 408             /* line break after 5 variables */
 409             if( (isplit+1) % 5 == 0 ) bprintf( "&\n    " );
 410           } else { /* after last part */
 411             bprintf( " /)\n" );
 412           }
 413         }
 414       }
 415
 416       break;
 417
 418     case MELM:  if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
 419                   else sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
 420                 if( (var->maxi == 0) ||
 421                     ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
 422                   strcat( maxi, "+1");
 423                 if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj );
 424                   else sprintf( maxj, "%s", varTable[ -var->maxj ]->name );
 425                 if( (var->maxj == 0) ||
 426                     ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) )
 427                   strcat( maxj, "+1");
 428                 sprintf( buf, "%s, DIMENSION(%s,%s) :: %s\n",   /* changed here */
 429                          baseType, maxi, maxj,var->name );
 430                 break;
 431     default:
 432                 printf( "Can not declare type %d", var->type );
 433                 break;
 434   }
 435   return buf;
 436 }
 437
 438 /*************************************************************************************************/
 439 void F90_Declare( int v )
 440 {
 441   if( varTable[ v ]->comment ) {
 442     F90_WriteComment( "%s - %s",
 443                     varTable[ v ]->name, varTable[ v ]->comment );
 444   }
 445   bprintf("  %s\n", F90_Decl(v) );
 446
 447   FlushBuf();
 448 }
 449
 450 /*************************************************************************************************/
 451 void F90_ExternDeclare( int v )
 452 {
 453   F90_Declare( v );
 454 //  bprintf("      COMMON /%s/ %s\n", CommonName, varTable[ v ]->name );
 455 }
 456
 457 /*************************************************************************************************/
 458 void F90_GlobalDeclare( int v )
 459 {
 460 }
 461
 462 /*************************************************************************************************/
 463 void F90_DeclareConstant( int v, char *val )
 464 {
 465 VARIABLE *var;
 466 int ival;
 467 char dummy_val[100];           /* used just to avoid strange behaviour of
 468                                   sscanf when compiled with gcc */
 469
 470   strcpy(dummy_val,val);val = dummy_val;
 471
 472   var = varTable[ v ];
 473
 474   if( sscanf(val, "%d", &ival) == 1 )
 475     if( ival == 0 ) var->maxi = 0;
 476                else var->maxi = 1;
 477   else
 478     var->maxi = -1;
 479
 480   if( var->comment )
 481     F90_WriteComment( "%s - %s", var->name, var->comment );
 482
 483   switch( var->type ) {
 484     case CONST: bprintf("  %s, PARAMETER :: %s = %s \n",
 485                        F90_types[ var->baseType ], var->name, val );
 486                 break;
 487     default:
 488                 printf( "Invalid constant %d", var->type );
 489                 break;
 490   }
 491
 492   FlushBuf();
 493 }
 494
 495
 496 /*************************************************************************************************/
 497 void F90_WriteVecData( VARIABLE * var, int min, int max, int split )
 498 {
 499 char buf[80];
 500 char *p;
 501
 502   if( split )
 503     sprintf( buf, "%6sdata( %s(i), i = %d, %d ) / &\n%5s",
 504                 " ", var->name, min, max, " " );
 505   else
 506     sprintf( buf, "%6sdata %s / &\n%5s",
 507                     " ", var->name, " " );
 508
 509   FlushThisBuf( buf );
 510   bprintf( " / \n\n" );
 511   FlushBuf();
 512 }
 513
 514 /*************************************************************************************************/
 515 void F90_DeclareDataOld( int v, int * values, int n )
 516 {
 517 int i, j;
 518 int nlines, min, max;
 519 int split;
 520 VARIABLE *var;
 521 int * ival;
 522 double * dval;
 523 char **cval;
 524 int maxCols = MAX_COLS;
 525 char dsbuf[55];
 526
 527   var = varTable[ v ];
 528   ival = (int*) values;
 529   dval = (double*) values;
 530   cval = (char**) values;
 531
 532   nlines = 1;
 533   min = max = 1;
 534   split = 0;
 535
 536   switch( var->type ) {
 537      case VELM: if( n <= 0 ) break;
 538                for( i = 0; i < n; i++ ) {
 539                  switch( var->baseType ) {
 540                    case INT: bprintf( "%3d",  ival[i] ); maxCols=12; break;
 541                    case DOUBLE:
 542                    case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break;
 543                    case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break;
 544                    case DOUBLESTRING:
 545                         strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0';
 546                         bprintf( "'%48s'", dsbuf ); maxCols=1; break;
 547                  }
 548                  if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) {
 549                      split = 1; nlines = 1;
 550                      F90_WriteVecData( var, min, max, split );
 551                      min = max + 1;
 552                  }
 553                  else {
 554                    if( i < n-1 ) bprintf( "," );
 555                    if( (i+1) % maxCols == 0 ) {
 556                      bprintf( "\n%5s", " " );
 557                      nlines++;
 558                    }
 559                  }
 560                  max ++;
 561                }
 562                F90_WriteVecData( var, min, max-1, split );
 563                break;
 564
 565     case ELM:  bprintf( "%6sdata %s / ", " ", var->name );
 566                switch( var->baseType ) {
 567                  case INT: bprintf( "%d",  *ival ); break;
 568                  case DOUBLE:
 569                  case REAL:bprintf( "%lg", *dval ); break;
 570                  case STRING:bprintf( "'%s'", *cval ); break;
 571                  case DOUBLESTRING:
 572                         strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0';
 573                         bprintf( "'%s'", dsbuf ); maxCols=1; break;
 574                         /* bprintf( "'%50s'", *cval ); break; */
 575                }
 576                bprintf( " / \n" );
 577                FlushBuf();
 578                break;
 579     default:
 580                printf( "\n Function not defined !\n" );
 581                break;
 582   }
 583 }
 584
 585 /*************************************************************************************************/
 586 void F90_InitDeclare( int v, int n, void * values )
 587 {
 588 int i;
 589 VARIABLE * var;
 590
 591   var = varTable[ v ];
 592   var->maxi = max( n, 1 );
 593
 594   NewLines(1);
 595   F90_DeclareData( v, values, n );
 596 }
 597
 598 /*************************************************************************************************/
 599 void F90_FunctionStart( int f, int *vars )
 600 {
 601 int i;
 602 int v;
 603 char * name;
 604 int narg;
 605
 606   name = varTable[ f ]->name;
 607   narg = varTable[ f ]->maxi;
 608
 609   bprintf("SUBROUTINE %s ( ", name );
 610   for( i = 0; i < narg-1; i++ ) {
 611     v = vars[ i ];
 612     bprintf("%s, ", varTable[ v ]->name );
 613   }
 614   if( narg >= 1 ) {
 615     v = vars[ narg-1 ];
 616     bprintf("%s ", varTable[ v ]->name );
 617   }
 618   bprintf(")\n");
 619
 620   FlushBuf();
 621 }
 622
 623 /*************************************************************************************************/
 624 void F90_FunctionPrototipe( int f, ... )
 625 {
 626 char * name;
 627 int narg;
 628
 629   name = varTable[ f ]->name;
 630   narg = varTable[ f ]->maxi;
 631
 632   bprintf("      EXTERNAL %s\n", name );
 633
 634   FlushBuf();
 635 }
 636
 637 /*************************************************************************************************/
 638 void F90_FunctionBegin( int f, ... )
 639 {
 640 Va_list args;
 641 int i;
 642 int v;
 643 int vars[20];
 644 char * name;
 645 int narg;
 646 FILE *oldf;
 647
 648   name = varTable[ f ]->name;
 649   narg = varTable[ f ]->maxi;
 650
 651   Va_start( args, f );
 652   for( i = 0; i < narg; i++ )
 653     vars[ i ] = va_arg( args, int );
 654   va_end( args );
 655
 656   CommentFncBegin( f, vars );
 657   F90_FunctionStart( f, vars );
 658   NewLines(1);
 659  /*  bprintf("  USE %s_Precision\n", rootFileName );
 660   bprintf("  USE %s_Parameters\n\n", rootFileName ); */
 661  /*  bprintf("      IMPLICIT NONE\n" ); */
 662
 663   FlushBuf();
 664
 665   for( i = 0; i < narg; i++ )
 666     F90_Declare( vars[ i ] );
 667
 668   bprintf("\n");
 669   FlushBuf();
 670
 671   MapFunctionComment( f, vars );
 672 }
 673
 674 /*************************************************************************************************/
 675 void F90_FunctionEnd( int f )
 676 {
 677   bprintf("      \nEND SUBROUTINE %s\n\n", varTable[ f ]->name );
 678
 679   FlushBuf();
 680
 681   CommentFunctionEnd( f );
 682 }
 683
 684 /*************************************************************************************************/
 685 void F90_Inline( char *fmt, ... )
 686 {
 687 va_list args;
 688 char buf[ 1000 ];
 689
 690   if( useLang != F90_LANG ) return;
 691
 692   va_start( args, fmt );
 693   vsprintf( buf, fmt, args );
 694   va_end( args );
 695   bprintf( "%s\n", buf );
 696
 697   FlushBuf();
 698
 699 }
 700
 701 /*************************************************************************************************/
 702 void Use_F90()
 703 {
 704   WriteElm          = F90_WriteElm;
 705   WriteSymbol       = F90_WriteSymbol;
 706   WriteAssign       = F90_WriteAssign;
 707   WriteComment      = F90_WriteComment;
 708   DeclareConstant   = F90_DeclareConstant;
 709   Declare           = F90_Declare;
 710   ExternDeclare     = F90_ExternDeclare;
 711   GlobalDeclare     = F90_GlobalDeclare;
 712   InitDeclare       = F90_InitDeclare;
 713
 714   FunctionStart     = F90_FunctionStart;
 715   FunctionPrototipe = F90_FunctionPrototipe;
 716   FunctionBegin     = F90_FunctionBegin;
 717   FunctionEnd       = F90_FunctionEnd;
 718
 719   OpenFile( &param_headerFile,   rootFileName, "_Parameters.f90", "Parameter Module File" );
 720   /*  mz_rs_20050117+ */
 721   OpenFile( &initFile, rootFileName, "_Initialize.f90", "Initialization File" );
 722   /*  mz_rs_20050117- */
 723   /* mz_rs_20050518+ no driver file if driver = none */
 724   if( strcmp( driver, "none" ) != 0 )
 725     OpenFile( &driverFile, rootFileName, "_Main.f90", "Main Program File" );
 726   /* mz_rs_20050518- */
 727   OpenFile( &integratorFile, rootFileName, "_Integrator.f90",
 728                    "Numerical Integrator (Time-Stepping) File" );
 729   OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.f90",
 730                    "Linear Algebra Data and Routines File" );
 731   OpenFile( &functionFile, rootFileName, "_Function.f90",
 732                    "The ODE Function of Chemical Model File" );
 733   OpenFile( &jacobianFile, rootFileName, "_Jacobian.f90",
 734                    "The ODE Jacobian of Chemical Model File" );
 735   OpenFile( &rateFile, rootFileName, "_Rates.f90",
 736                    "The Reaction Rates File" );
 737   if ( useStochastic )
 738     OpenFile( &stochasticFile, rootFileName, "_Stochastic.f90",
 739                    "The Stochastic Chemical Model File" );
 740   if ( useStoicmat ) {
 741      OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.f90",
 742                    "The Stoichiometric Chemical Model File" );
 743      OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.f90",
 744                    "Sparse Stoichiometric Data Structures File" );
 745   }
 746   OpenFile( &utilFile, rootFileName, "_Util.f90",
 747                    "Auxiliary Routines File" );
 748   /* OpenFile( &sparse_dataFile, rootFileName, "_Sparse.f90",
 749                        "Sparse Data Module File" );*/
 750   OpenFile( &global_dataFile, rootFileName, "_Global.f90", "Global Data Module File" );
 751   if ( useJacSparse ) {
 752      OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.f90",
 753          "Sparse Jacobian Data Structures File" );
 754   }
 755   if ( useHessian ) {
 756      OpenFile( &hessianFile, rootFileName, "_Hessian.f90", "Hessian File" );
 757      OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f90",
 758          "Sparse Hessian Data Structures File" );
 759   }
 760   OpenFile( &mapFile, rootFileName, ".map",
 761                    "Map File with Human-Readable Information" );
 762   OpenFile( &monitorFile, rootFileName, "_Monitor.f90",
 763                    "Utility Data Module File" );
 764 }