source: palm/trunk/UTIL/chemistry/gasphase_preproc/kpp/src/code_f77.c @ 4843

Last change on this file since 4843 was 4843, checked in by raasch, 16 months ago

local namelist parameter added to switch off the module although the respective module namelist appears in the namelist file, further copyright updates

File size: 18.1 KB
Line 
1/******************************************************************************
2
3  KPP - The Kinetic PreProcessor
4        Builds simulation code for chemical kinetic systems
5
6  Copyright (C) -2021 996 Valeriu Damian and Adrian Sandu
7  Copyright (C) -2021 005 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
40char *F77_types[] = { "",                 /* VOID */ 
41                    "INTEGER",          /* INT */
42                    "REAL",             /* FLOAT */
43                    "REAL*8",           /* DOUBLE */
44                    "CHARACTER*12",     /* STRING */
45                    "CHARACTER*100"     /* DOUBLESTRING */
46                  };
47
48/*************************************************************************************************/
49void F77_WriteElm( NODE * n )
50{
51ELEMENT *elm;
52char * name;
53char maxi[20];
54char 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/*************************************************************************************************/
80void F77_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/*************************************************************************************************/
108void F77_WriteAssign( char *ls, char *rs )
109{
110int start;
111int linelg;
112int i,j;
113char c;
114int first;
115int crtident;
116int number_of_lines = 1, MAX_NO_OF_LINES = 36;
117int ifound, jfound;
118   
119/*  Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ','
120                      0xad = '-' | 0xae ='.' | 0xaf = '/' */                 
121/* char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; */               
122char op_mult='*', op_plus='+', op_minus='-', op_dot='.', op_div='/';                 
123 
124  crtident = 6 + ident * 2;
125  bprintf("%*s%s = ", crtident, "", ls);
126  start = strlen( ls ) + 2;
127  linelg = 70 - crtident - start - 1;
128
129  first = 1;
130  while( strlen(rs) > linelg ) {
131    ifound = 0; jfound = 0;
132    if ( number_of_lines >= MAX_NO_OF_LINES ) {/* if a new line needs to be started */
133     for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */
134       if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { 
135        jfound = 1; i=j; break;
136        }
137    }
138    if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) {
139     for( i=linelg; i>10; i-- ) /* split row here if operator or comma */
140       if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) {
141        ifound = 1; break;
142        }
143     if( i <= 10 ) {
144      printf("\n Warning: possible error in continuation lines for %s = ...",ls);
145      i = linelg;
146     }
147    } 
148    while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */
149    while ( rs[i] == ',' ) i++; /* put commas on the current row */
150   
151    /*for( i=linelg; i>10; i-- )
152      if( ( rs[i] & 0x80 )||( rs[i]==',' ) )
153        break;
154    if( i < 10 ) {
155      printf("\nPossible error when cutting lines");
156      i = linelg;
157    } */
158       
159    c = rs[i]; 
160    rs[i] = 0;
161   
162    if ( first ) { /* first line in a split row */
163      bprintf("%s", rs );
164      linelg++;
165      first = 0;
166    } else {/* continuation line in a split row - but not last line*/
167      bprintf("\n     &%*s%s", start, "", rs );
168      if ( jfound ) {
169         bprintf("\n%*s%s = %s", crtident, "", ls, ls);
170         number_of_lines = 1;
171         }
172    } 
173    rs[i] = c;
174    rs += i;
175    number_of_lines++;
176  }
177
178  if ( number_of_lines > MAX_NO_OF_LINES )
179     printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines,ls);
180 
181  if ( first ) bprintf("%s\n", rs ); /* non-split row */
182          else bprintf("\n     &%*s%s\n", start, "", rs ); /* last line in a split row */
183
184  FlushBuf();
185}
186
187
188/*************************************************************************************************/
189void F77_WriteComment( char *fmt, ... )
190{
191Va_list args;
192char buf[ MAX_LINE ];
193
194  Va_start( args, fmt );
195  vsprintf( buf, fmt, args );
196  va_end( args );
197  bprintf( "C %-65s\n", buf );
198
199  FlushBuf();
200}
201
202/*************************************************************************************************/
203char * F77_Decl( int v )
204{
205static char buf[120];
206VARIABLE *var;
207char *baseType;
208char maxi[20];
209char maxj[20];
210
211  var = varTable[ v ];
212  baseType = F77_types[ var->baseType ];
213 
214  *buf = 0;
215
216  switch( var->type ) {
217    case ELM:   sprintf( buf, "%s %s",
218                        baseType, var->name );
219                break;
220    case VELM: 
221                if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
222                if( var->maxi == 0 ) sprintf( maxi, "%d", 1 );
223                /*  else sprintf( maxi, "%s", varTable[ -var->maxi ]->name);  */
224                if ( var->maxi < 0 ) {
225                    if (varTable[ -var->maxi ]->value < 0) 
226                      sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
227                    else 
228                      sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0?
229                           1:varTable[-var->maxi]->value );
230                  } 
231                /* if( (var->maxi == 0) ||
232                    ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
233                  strcat( maxi, "+1"); */
234                sprintf( buf, "%s %s(%s)",
235                        baseType, var->name, maxi );
236                break;
237    case MELM:  if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
238               else { 
239                 if (varTable[ -var->maxi ]->value < 0)
240                    sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
241                 else 
242                    sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0?
243                           1:varTable[-var->maxi]->value );
244               } 
245                /* if( (var->maxi == 0) ||
246                    ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
247                  strcat( maxi, "+1"); */
248                if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj );
249                else {
250                  if (varTable[ -var->maxj ]->value < 0)
251                     sprintf( maxj, "%s", varTable[ -var->maxj ]->name );
252                  else 
253                     sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0?
254                           1:varTable[-var->maxj]->value );
255                  } 
256                /*if( (var->maxj == 0) ||
257                    ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) )
258                  strcat( maxj, "+1");*/
259                sprintf( buf, "%s %s(%s,%s)",
260                         baseType, var->name, maxi, maxj ); 
261                break;
262    default:
263                printf( "Can not declare type %d\n", var->type );
264                break;
265  }
266  return buf;
267}
268
269/*************************************************************************************************/
270void F77_Declare( int v )
271{
272  if( varTable[ v ]->comment ) {
273    F77_WriteComment( "%s - %s", 
274                    varTable[ v ]->name, varTable[ v ]->comment );
275  }
276  bprintf("      %s\n", F77_Decl(v) );
277
278  FlushBuf();
279}
280
281/*************************************************************************************************/
282void F77_ExternDeclare( int v )
283{
284  F77_Declare( v );
285  bprintf("      COMMON /%s/ %s\n", CommonName, varTable[ v ]->name );
286}
287
288/*************************************************************************************************/
289void F77_GlobalDeclare( int v )
290{
291}
292
293/*************************************************************************************************/
294void F77_DeclareConstant( int v, char *val ) 
295{
296VARIABLE *var;
297int ival;
298char dummy_val[100];           /* used just to avoid strange behaviour of
299                                  sscanf when compiled with gcc */
300                                 
301  strcpy(dummy_val,val);val = dummy_val;
302
303  var = varTable[ v ];
304 
305  if( sscanf(val, "%d", &ival) == 1 )
306    if( ival == 0 ) var->maxi = 0;
307               else var->maxi = 1;
308  else
309    var->maxi = -1;       
310 
311  if( var->comment ) 
312    F77_WriteComment( "%s - %s", var->name, var->comment );
313
314  switch( var->type ) {
315    case CONST: bprintf("      %s %s\n", 
316                       F77_types[ var->baseType ], var->name );
317                bprintf("      PARAMETER ( %s = %s )\n", 
318                       var->name, val);
319                break;       
320    default:
321                printf( "Invalid constant %d", var->type );
322                break;
323  }
324
325  FlushBuf();
326}
327
328/*************************************************************************************************/
329void WriteVecData( VARIABLE * var, int min, int max, int split )
330{
331char buf[80];
332char *p;
333
334  if( split )
335    sprintf( buf, "%6sDATA( %s(i), i = %d, %d ) /\n%5s*", 
336                " ", var->name, min, max, " " );
337  else
338    sprintf( buf, "%6sDATA %s /\n%5s*",
339                    " ", var->name, " " );
340                                     
341  FlushThisBuf( buf );
342  bprintf( " / \n\n" );
343  FlushBuf();       
344}
345
346/*************************************************************************************************/
347void F77_DeclareData( int v, int * values, int n )
348{
349int i, j;
350int nlines, min, max;
351int split;
352VARIABLE *var;
353int * ival;
354double * dval;
355char **cval;
356int maxCols = MAX_COLS;
357char dsbuf[55];
358
359  var = varTable[ v ];
360  ival = (int*) values;
361  dval = (double*) values;
362  cval = (char**) values;
363   
364  nlines = 1;
365  min = max = 1;
366  split = 0;
367
368  switch( var->type ) {
369    case VELM: if( n <= 0 ) break;
370               for( i = 0; i < n; i++ ) {
371                 switch( var->baseType ) {
372                   case INT: bprintf( "%3d",  ival[i] ); maxCols=12; break;
373                   case DOUBLE: 
374                   case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break;
375                   case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break;
376                   case DOUBLESTRING:
377                        strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0';
378                        bprintf( "'%48s'", dsbuf ); maxCols=1; break;
379                 }
380                 if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) {
381                     split = 1; nlines = 1;
382                     WriteVecData( var, min, max, split ); 
383                     min = max + 1;
384                 } 
385                 else { 
386                   if( i < n-1 ) bprintf( "," );
387                   if( (i+1) % maxCols == 0 ) { 
388                     bprintf( "\n%5s*", " " );
389                     nlines++;                 
390                   } 
391                 } 
392                 max ++;
393               }
394               WriteVecData( var, min, max-1, split );
395               break;
396                                                                 
397    case ELM:  bprintf( "%6sDATA %s / ", " ", var->name );
398               switch( var->baseType ) {
399                 case INT: bprintf( "%d",  *ival ); break;
400                 case DOUBLE: 
401                 case REAL:bprintf( "%lg", *dval ); break;
402                 case STRING:bprintf( "'%s'", *cval ); break;
403                 case DOUBLESTRING:                     
404                        strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0';
405                        bprintf( "'%s'", dsbuf ); maxCols=1; break;
406                        /* bprintf( "'%50s'", *cval ); break; */
407               }
408               bprintf( " / \n" );
409               FlushBuf();
410               break;
411    default:
412               printf( "\n Function not defined !\n" );
413               break;
414  }
415}
416
417/*************************************************************************************************/
418void F77_InitDeclare( int v, int n, void * values )
419{
420int i;
421VARIABLE * var;
422
423  var = varTable[ v ];
424  var->maxi = max( n, 1 );
425
426  NewLines(1); 
427  F77_DeclareData( v, values, n );
428}
429
430/*************************************************************************************************/
431void F77_FunctionStart( int f, int *vars )
432{
433int i;
434int v;
435char * name;
436int narg;
437
438  name = varTable[ f ]->name;
439  narg = varTable[ f ]->maxi;
440
441  bprintf("      SUBROUTINE %s ( ", name );
442  for( i = 0; i < narg-1; i++ ) {
443    v = vars[ i ];
444    bprintf("%s, ", varTable[ v ]->name );
445  }
446  if( narg >= 1 ) {
447    v = vars[ narg-1 ];
448    bprintf("%s ", varTable[ v ]->name );
449  }
450  bprintf(")\n");
451
452  FlushBuf();
453}                 
454
455/*************************************************************************************************/
456void F77_FunctionPrototipe( int f, ... )
457{
458char * name;
459int narg;
460
461  name = varTable[ f ]->name;
462  narg = varTable[ f ]->maxi;
463
464  bprintf("      EXTERNAL %s\n", name );
465
466  FlushBuf();
467}
468
469/*************************************************************************************************/
470void F77_FunctionBegin( int f, ... )
471{
472Va_list args;
473int i;
474int v;
475int vars[20];
476char * name;
477int narg;
478FILE *oldf;
479
480  name = varTable[ f ]->name;
481  narg = varTable[ f ]->maxi;
482   
483  Va_start( args, f );
484  for( i = 0; i < narg; i++ ) 
485    vars[ i ] = va_arg( args, int );
486  va_end( args );
487   
488  CommentFncBegin( f, vars );
489  F77_FunctionStart( f, vars );
490  NewLines(1);
491  bprintf("      IMPLICIT NONE\n" );
492  bprintf("      INCLUDE '%s_Parameters.h'\n\n", rootFileName );
493
494  FlushBuf();
495
496  for( i = 0; i < narg; i++ ) 
497    F77_Declare( vars[ i ] );
498
499  bprintf("\n");
500  FlushBuf();
501
502  MapFunctionComment( f, vars );
503}
504
505/*************************************************************************************************/
506void F77_FunctionEnd( int f )
507{
508  bprintf("      RETURN\n");
509  bprintf("      END\n\n");
510
511  FlushBuf();
512
513  CommentFunctionEnd( f );
514}
515
516/*************************************************************************************************/
517void F77_Inline( char *fmt, ... )
518{
519Va_list args;
520char buf[ 1000 ];
521
522  if( useLang != F77_LANG ) return;
523 
524  Va_start( args, fmt );
525  vsprintf( buf, fmt, args );
526  va_end( args );
527  bprintf( "%s\n", buf );
528 
529  FlushBuf();
530}
531
532/*************************************************************************************************/
533void Use_F()
534{ 
535  WriteElm          = F77_WriteElm;
536  WriteSymbol       = F77_WriteSymbol; 
537  WriteAssign       = F77_WriteAssign;
538  WriteComment      = F77_WriteComment;
539  DeclareConstant   = F77_DeclareConstant;
540  Declare           = F77_Declare;
541  ExternDeclare     = F77_ExternDeclare;
542  GlobalDeclare     = F77_GlobalDeclare;
543  InitDeclare       = F77_InitDeclare;
544
545  FunctionStart     = F77_FunctionStart;
546  FunctionPrototipe = F77_FunctionPrototipe;
547  FunctionBegin     = F77_FunctionBegin;
548  FunctionEnd       = F77_FunctionEnd;
549
550  OpenFile( &param_headerFile,   rootFileName, "_Parameters.h", "Parameter Header File" );
551  OpenFile( &initFile, rootFileName, "_Initialize.f", "Initialization File" );
552  OpenFile( &driverFile, rootFileName, "_Main.f", "Main Program File" );
553  OpenFile( &integratorFile, rootFileName, "_Integrator.f", 
554                   "Numerical Integrator (Time-Stepping) File" );
555  OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.f", 
556                   "Linear Algebra Data and Routines File" );
557  OpenFile( &functionFile, rootFileName, "_Function.f", 
558                   "The ODE Function of Chemical Model File" );
559  OpenFile( &jacobianFile, rootFileName, "_Jacobian.f", 
560                   "The ODE Jacobian of Chemical Model File" );
561  OpenFile( &rateFile, rootFileName, "_Rates.f", 
562                   "The Reaction Rates File" );
563  if ( useStochastic )
564    OpenFile( &stochasticFile, rootFileName, "_Stochastic.f", 
565                   "The Stochastic Chemical Model File" );
566  if ( useStoicmat ) {
567     OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.f", 
568                   "The Stoichiometric Chemical Model File" );
569     OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.f", 
570                   "Sparse Stoichiometric Data Structures File" );
571  }               
572  OpenFile( &utilFile, rootFileName, "_Util.f", 
573                   "Auxiliary Routines File" );
574  OpenFile( &sparse_dataFile, rootFileName, "_Sparse.h", "Sparse Data Header File" );
575  OpenFile( &global_dataFile, rootFileName, "_Global.h", "Global Data Header File" );
576  if ( useJacSparse ) {
577     OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.f",
578         "Sparse Jacobian Data Structures File" ); 
579  }
580  if ( useHessian ) {
581     OpenFile( &hessianFile, rootFileName, "_Hessian.f", "Hessian File" );
582     OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f",
583         "Sparse Hessian Data Structures File" );
584  }     
585  OpenFile( &mapFile, rootFileName, ".map", 
586                   "Map File with Human-Readable Information" );
587  OpenFile( &monitorFile, rootFileName, "_Monitor.f", 
588                   "Initialization of Utility Data Structures" );
589} 
Note: See TracBrowser for help on using the repository browser.