Home


About us
PALM
PALM-4U
Installation
Release notes
Documentation
Getting Help
Gallery
Developers area

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

Last change on this file since 4845 was 4843, checked in by raasch, 4 years 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.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |