1 /******************************************************************************
3 KPP - The Kinetic PreProcessor
4 Builds simulation code for chemical kinetic systems
6 Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu
7 Copyright (C) 1997-2005 Adrian Sandu
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.
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
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.
25 Computer Science Department
26 Virginia Polytechnic Institute and State University
28 E-mail: sandu@cs.vt.edu
30 ******************************************************************************/
40 char *F77_types
[] = { "", /* VOID */
43 "REAL*8", /* DOUBLE */
44 "CHARACTER*12", /* STRING */
45 "CHARACTER*100" /* DOUBLESTRING */
48 /*************************************************************************************************/
49 void F77_WriteElm( NODE
* n
)
57 name
= varTable
[ elm
->var
]->name
;
60 case CONST
: bprintf("%g", elm
->val
.cnst
);
62 case ELM
: bprintf("%s", name
);
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
);
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
);
74 case EELM
: bprintf("(%s)", elm
->val
.expr
);
79 /*************************************************************************************************/
80 void F77_WriteSymbol( int op
)
83 case ADD
: bprintf("+");
86 case SUB
: bprintf("-");
89 case MUL
: bprintf("*");
92 case DIV
: bprintf("/");
95 case POW
: bprintf("power");
97 case O_PAREN
: bprintf("(");
100 case C_PAREN
: bprintf(")");
107 /*************************************************************************************************/
108 void F77_WriteAssign( char *ls
, char *rs
)
116 int number_of_lines
= 1, MAX_NO_OF_LINES
= 36;
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;
123 crtident
= 6 + ident
* 2;
124 bprintf("%*s%s = ", crtident
, "", ls
);
125 start
= strlen( ls
) + 2;
126 linelg
= 70 - crtident
- start
- 1;
129 while( strlen(rs
) > linelg
) {
130 ifound
= 0; jfound
= 0;
131 if ( number_of_lines
>= MAX_NO_OF_LINES
) {/* if a new line needs to be started */
132 for( j
=linelg
; j
>5; j
-- ) /* split row here if +, -, or comma */
133 if ( ( rs
[j
] == op_plus
)||( rs
[j
] == op_minus
)||( rs
[j
]==',' ) ) {
134 jfound
= 1; i
=j
; break;
137 if ( ( number_of_lines
< MAX_NO_OF_LINES
)||( !jfound
) ) {
138 for( i
=linelg
; i
>10; i
-- ) /* split row here if operator or comma */
139 if ( ( rs
[i
] & 0x80 )||( rs
[i
]==',' ) ) {
143 printf("\n Warning: possible error in continuation lines for %s = ...",ls
);
147 while ( rs
[i
-1] & 0x80 ) i
--; /* put all operators on the next row */
148 while ( rs
[i
] == ',' ) i
++; /* put commas on the current row */
150 /*for( i=linelg; i>10; i-- )
151 if( ( rs[i] & 0x80 )||( rs[i]==',' ) )
154 printf("\nPossible error when cutting lines");
161 if ( first
) { /* first line in a split row */
165 } else {/* continuation line in a split row - but not last line*/
166 bprintf("\n &%*s%s", start
, "", rs
);
168 bprintf("\n%*s%s = %s", crtident
, "", ls
, ls
);
177 if ( number_of_lines
> MAX_NO_OF_LINES
)
178 printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines
,ls
);
180 if ( first
) bprintf("%s\n", rs
); /* non-split row */
181 else bprintf("\n &%*s%s\n", start
, "", rs
); /* last line in a split row */
187 /*************************************************************************************************/
188 void F77_WriteComment( char *fmt
, ... )
191 char buf
[ MAX_LINE
];
193 Va_start( args
, fmt
);
194 vsprintf( buf
, fmt
, args
);
196 bprintf( "C %-65s\n", buf
);
201 /*************************************************************************************************/
202 char * F77_Decl( int v
)
204 static char buf
[120];
211 baseType
= F77_types
[ var
->baseType
];
215 switch( var
->type
) {
216 case ELM
: sprintf( buf
, "%s %s",
217 baseType
, var
->name
);
220 if( var
->maxi
> 0 ) sprintf( maxi
, "%d", var
->maxi
);
221 if( var
->maxi
== 0 ) sprintf( maxi
, "%d", 1 );
222 /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */
223 if ( var
->maxi
< 0 ) {
224 if (varTable
[ -var
->maxi
]->value
< 0)
225 sprintf( maxi
, "%s", varTable
[ -var
->maxi
]->name
);
227 sprintf( maxi
, "%d", (varTable
[-var
->maxi
]->value
)==0?
228 1:varTable
[-var
->maxi
]->value
);
230 /* if( (var->maxi == 0) ||
231 ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
232 strcat( maxi, "+1"); */
233 sprintf( buf
, "%s %s(%s)",
234 baseType
, var
->name
, maxi
);
236 case MELM
: if( var
->maxi
> 0 ) sprintf( maxi
, "%d", var
->maxi
);
238 if (varTable
[ -var
->maxi
]->value
< 0)
239 sprintf( maxi
, "%s", varTable
[ -var
->maxi
]->name
);
241 sprintf( maxi
, "%d", (varTable
[-var
->maxi
]->value
)==0?
242 1:varTable
[-var
->maxi
]->value
);
244 /* if( (var->maxi == 0) ||
245 ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) )
246 strcat( maxi, "+1"); */
247 if( var
->maxj
> 0 ) sprintf( maxj
, "%d", var
->maxj
);
249 if (varTable
[ -var
->maxj
]->value
< 0)
250 sprintf( maxj
, "%s", varTable
[ -var
->maxj
]->name
);
252 sprintf( maxj
, "%d", (varTable
[-var
->maxj
]->value
)==0?
253 1:varTable
[-var
->maxj
]->value
);
255 /*if( (var->maxj == 0) ||
256 ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) )
257 strcat( maxj, "+1");*/
258 sprintf( buf
, "%s %s(%s,%s)",
259 baseType
, var
->name
, maxi
, maxj
);
262 printf( "Can not declare type %d\n", var
->type
);
268 /*************************************************************************************************/
269 void F77_Declare( int v
)
271 if( varTable
[ v
]->comment
) {
272 F77_WriteComment( "%s - %s",
273 varTable
[ v
]->name
, varTable
[ v
]->comment
);
275 bprintf(" %s\n", F77_Decl(v
) );
280 /*************************************************************************************************/
281 void F77_ExternDeclare( int v
)
284 bprintf(" COMMON /%s/ %s\n", CommonName
, varTable
[ v
]->name
);
287 /*************************************************************************************************/
288 void F77_GlobalDeclare( int v
)
292 /*************************************************************************************************/
293 void F77_DeclareConstant( int v
, char *val
)
297 char dummy_val
[100]; /* used just to avoid strange behaviour of
298 sscanf when compiled with gcc */
300 strcpy(dummy_val
,val
);val
= dummy_val
;
304 if( sscanf(val
, "%d", &ival
) == 1 )
305 if( ival
== 0 ) var
->maxi
= 0;
311 F77_WriteComment( "%s - %s", var
->name
, var
->comment
);
313 switch( var
->type
) {
314 case CONST
: bprintf(" %s %s\n",
315 F77_types
[ var
->baseType
], var
->name
);
316 bprintf(" PARAMETER ( %s = %s )\n",
320 printf( "Invalid constant %d", var
->type
);
327 /*************************************************************************************************/
328 void WriteVecData( VARIABLE
* var
, int min
, int max
, int split
)
334 sprintf( buf
, "%6sDATA( %s(i), i = %d, %d ) /\n%5s*",
335 " ", var
->name
, min
, max
, " " );
337 sprintf( buf
, "%6sDATA %s /\n%5s*",
338 " ", var
->name
, " " );
341 bprintf( " / \n\n" );
345 /*************************************************************************************************/
346 void F77_DeclareData( int v
, int * values
, int n
)
349 int nlines
, min
, max
;
355 int maxCols
= MAX_COLS
;
359 ival
= (int*) values
;
360 dval
= (double*) values
;
361 cval
= (char**) values
;
367 switch( var
->type
) {
368 case VELM
: if( n
<= 0 ) break;
369 for( i
= 0; i
< n
; i
++ ) {
370 switch( var
->baseType
) {
371 case INT
: bprintf( "%3d", ival
[i
] ); maxCols
=12; break;
373 case REAL
:bprintf( "%5lg", dval
[i
] ); maxCols
=8; break;
374 case STRING
:bprintf( "'%s'", cval
[i
] ); maxCols
=5; break;
376 strncpy( dsbuf
, cval
[i
], 54 ); dsbuf
[54]='\0';
377 bprintf( "'%48s'", dsbuf
); maxCols
=1; break;
379 if( ( (i
+1) % 12 == 0 ) && ( nlines
> MAX_LINES
) ) {
380 split
= 1; nlines
= 1;
381 WriteVecData( var
, min
, max
, split
);
385 if( i
< n
-1 ) bprintf( "," );
386 if( (i
+1) % maxCols
== 0 ) {
387 bprintf( "\n%5s*", " " );
393 WriteVecData( var
, min
, max
-1, split
);
396 case ELM
: bprintf( "%6sDATA %s / ", " ", var
->name
);
397 switch( var
->baseType
) {
398 case INT
: bprintf( "%d", *ival
); break;
400 case REAL
:bprintf( "%lg", *dval
); break;
401 case STRING
:bprintf( "'%s'", *cval
); break;
403 strncpy( dsbuf
, *cval
, 54 ); dsbuf
[54]='\0';
404 bprintf( "'%s'", dsbuf
); maxCols
=1; break;
405 /* bprintf( "'%50s'", *cval ); break; */
411 printf( "\n Function not defined !\n" );
416 /*************************************************************************************************/
417 void F77_InitDeclare( int v
, int n
, void * values
)
423 var
->maxi
= max( n
, 1 );
426 F77_DeclareData( v
, values
, n
);
429 /*************************************************************************************************/
430 void F77_FunctionStart( int f
, int *vars
)
437 name
= varTable
[ f
]->name
;
438 narg
= varTable
[ f
]->maxi
;
440 bprintf(" SUBROUTINE %s ( ", name
);
441 for( i
= 0; i
< narg
-1; i
++ ) {
443 bprintf("%s, ", varTable
[ v
]->name
);
447 bprintf("%s ", varTable
[ v
]->name
);
454 /*************************************************************************************************/
455 void F77_FunctionPrototipe( int f
, ... )
460 name
= varTable
[ f
]->name
;
461 narg
= varTable
[ f
]->maxi
;
463 bprintf(" EXTERNAL %s\n", name
);
468 /*************************************************************************************************/
469 void F77_FunctionBegin( int f
, ... )
479 name
= varTable
[ f
]->name
;
480 narg
= varTable
[ f
]->maxi
;
483 for( i
= 0; i
< narg
; i
++ )
484 vars
[ i
] = va_arg( args
, int );
487 CommentFncBegin( f
, vars
);
488 F77_FunctionStart( f
, vars
);
490 bprintf(" IMPLICIT NONE\n" );
491 bprintf(" INCLUDE '%s_Parameters.h'\n\n", rootFileName
);
495 for( i
= 0; i
< narg
; i
++ )
496 F77_Declare( vars
[ i
] );
501 MapFunctionComment( f
, vars
);
504 /*************************************************************************************************/
505 void F77_FunctionEnd( int f
)
507 bprintf(" RETURN\n");
512 CommentFunctionEnd( f
);
515 /*************************************************************************************************/
516 void F77_Inline( char *fmt
, ... )
521 if( useLang
!= F77_LANG
) return;
523 Va_start( args
, fmt
);
524 vsprintf( buf
, fmt
, args
);
526 bprintf( "%s\n", buf
);
531 /*************************************************************************************************/
534 WriteElm
= F77_WriteElm
;
535 WriteSymbol
= F77_WriteSymbol
;
536 WriteAssign
= F77_WriteAssign
;
537 WriteComment
= F77_WriteComment
;
538 DeclareConstant
= F77_DeclareConstant
;
539 Declare
= F77_Declare
;
540 ExternDeclare
= F77_ExternDeclare
;
541 GlobalDeclare
= F77_GlobalDeclare
;
542 InitDeclare
= F77_InitDeclare
;
544 FunctionStart
= F77_FunctionStart
;
545 FunctionPrototipe
= F77_FunctionPrototipe
;
546 FunctionBegin
= F77_FunctionBegin
;
547 FunctionEnd
= F77_FunctionEnd
;
549 OpenFile( ¶m_headerFile
, rootFileName
, "_Parameters.h", "Parameter Header File" );
550 OpenFile( &initFile
, rootFileName
, "_Initialize.f", "Initialization File" );
551 OpenFile( &driverFile
, rootFileName
, "_Main.f", "Main Program File" );
552 OpenFile( &integratorFile
, rootFileName
, "_Integrator.f",
553 "Numerical Integrator (Time-Stepping) File" );
554 OpenFile( &linalgFile
, rootFileName
, "_LinearAlgebra.f",
555 "Linear Algebra Data and Routines File" );
556 OpenFile( &functionFile
, rootFileName
, "_Function.f",
557 "The ODE Function of Chemical Model File" );
558 OpenFile( &jacobianFile
, rootFileName
, "_Jacobian.f",
559 "The ODE Jacobian of Chemical Model File" );
560 OpenFile( &rateFile
, rootFileName
, "_Rates.f",
561 "The Reaction Rates File" );
563 OpenFile( &stochasticFile
, rootFileName
, "_Stochastic.f",
564 "The Stochastic Chemical Model File" );
566 OpenFile( &stoichiomFile
, rootFileName
, "_Stoichiom.f",
567 "The Stoichiometric Chemical Model File" );
568 OpenFile( &sparse_stoicmFile
, rootFileName
, "_StoichiomSP.f",
569 "Sparse Stoichiometric Data Structures File" );
571 OpenFile( &utilFile
, rootFileName
, "_Util.f",
572 "Auxiliary Routines File" );
573 OpenFile( &sparse_dataFile
, rootFileName
, "_Sparse.h", "Sparse Data Header File" );
574 OpenFile( &global_dataFile
, rootFileName
, "_Global.h", "Global Data Header File" );
575 if ( useJacSparse
) {
576 OpenFile( &sparse_jacFile
, rootFileName
, "_JacobianSP.f",
577 "Sparse Jacobian Data Structures File" );
580 OpenFile( &hessianFile
, rootFileName
, "_Hessian.f", "Hessian File" );
581 OpenFile( &sparse_hessFile
, rootFileName
, "_HessianSP.f",
582 "Sparse Hessian Data Structures File" );
584 OpenFile( &mapFile
, rootFileName
, ".map",
585 "Map File with Human-Readable Information" );
586 OpenFile( &monitorFile
, rootFileName
, "_Monitor.f",
587 "Initialization of Utility Data Structures" );