?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
added README_changes.txt
[wrffire.git] / wrfv2_fire / chem / KPP / kpp / kpp-2.1 / src.org / code_f77.c
blobce8b1e5fe701cf926ade62caacbd1a98c73356dd
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 *F77_types[] = { "", /* VOID */
41 "INTEGER", /* INT */
42 "REAL", /* FLOAT */
43 "REAL*8", /* DOUBLE */
44 "CHARACTER*12", /* STRING */
45 "CHARACTER*100" /* DOUBLESTRING */
46 };
47
48 /*************************************************************************************************/
49 void F77_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 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 /*************************************************************************************************/
108 void F77_WriteAssign( char *ls, char *rs )
109 {
110 int start;
111 int linelg;
112 int i,j;
113 char c;
114 int first;
115 int crtident;
116 int number_of_lines = 1, MAX_NO_OF_LINES = 36;
117 int 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;
122
123 crtident = 6 + ident * 2;
124 bprintf("%*s%s = ", crtident, "", ls);
125 start = strlen( ls ) + 2;
126 linelg = 70 - crtident - start - 1;
127
128 first = 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;
135 }
136 }
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]==',' ) ) {
140 ifound = 1; break;
141 }
142 if( i <= 10 ) {
143 printf("\n Warning: possible error in continuation lines for %s = ...",ls);
144 i = linelg;
145 }
146 }
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 */
149
150 /*for( i=linelg; i>10; i-- )
151 if( ( rs[i] & 0x80 )||( rs[i]==',' ) )
152 break;
153 if( i < 10 ) {
154 printf("\nPossible error when cutting lines");
155 i = linelg;
156 } */
157
158 c = rs[i];
159 rs[i] = 0;
160
161 if ( first ) { /* first line in a split row */
162 bprintf("%s", rs );
163 linelg++;
164 first = 0;
165 } else {/* continuation line in a split row - but not last line*/
166 bprintf("\n &%*s%s", start, "", rs );
167 if ( jfound ) {
168 bprintf("\n%*s%s = %s", crtident, "", ls, ls);
169 number_of_lines = 1;
170 }
171 }
172 rs[i] = c;
173 rs += i;
174 number_of_lines++;
175 }
176
177 if ( number_of_lines > MAX_NO_OF_LINES )
178 printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines,ls);
179
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 */
182
183 FlushBuf();
184 }
185
186
187 /*************************************************************************************************/
188 void F77_WriteComment( char *fmt, ... )
189 {
190 Va_list args;
191 char buf[ MAX_LINE ];
192
193 Va_start( args, fmt );
194 vsprintf( buf, fmt, args );
195 va_end( args );
196 bprintf( "C %-65s\n", buf );
197
198 FlushBuf();
199 }
200
201 /*************************************************************************************************/
202 char * F77_Decl( int v )
203 {
204 static char buf[120];
205 VARIABLE *var;
206 char *baseType;
207 char maxi[20];
208 char maxj[20];
209
210 var = varTable[ v ];
211 baseType = F77_types[ var->baseType ];
212
213 *buf = 0;
214
215 switch( var->type ) {
216 case ELM: sprintf( buf, "%s %s",
217 baseType, var->name );
218 break;
219 case VELM:
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 );
226 else
227 sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0?
228 1:varTable[-var->maxi]->value );
229 }
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 );
235 break;
236 case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi );
237 else {
238 if (varTable[ -var->maxi ]->value < 0)
239 sprintf( maxi, "%s", varTable[ -var->maxi ]->name );
240 else
241 sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0?
242 1:varTable[-var->maxi]->value );
243 }
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 );
248 else {
249 if (varTable[ -var->maxj ]->value < 0)
250 sprintf( maxj, "%s", varTable[ -var->maxj ]->name );
251 else
252 sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0?
253 1:varTable[-var->maxj]->value );
254 }
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 );
260 break;
261 default:
262 printf( "Can not declare type %d\n", var->type );
263 break;
264 }
265 return buf;
266 }
267
268 /*************************************************************************************************/
269 void F77_Declare( int v )
270 {
271 if( varTable[ v ]->comment ) {
272 F77_WriteComment( "%s - %s",
273 varTable[ v ]->name, varTable[ v ]->comment );
274 }
275 bprintf(" %s\n", F77_Decl(v) );
276
277 FlushBuf();
278 }
279
280 /*************************************************************************************************/
281 void F77_ExternDeclare( int v )
282 {
283 F77_Declare( v );
284 bprintf(" COMMON /%s/ %s\n", CommonName, varTable[ v ]->name );
285 }
286
287 /*************************************************************************************************/
288 void F77_GlobalDeclare( int v )
289 {
290 }
291
292 /*************************************************************************************************/
293 void F77_DeclareConstant( int v, char *val )
294 {
295 VARIABLE *var;
296 int ival;
297 char dummy_val[100]; /* used just to avoid strange behaviour of
298 sscanf when compiled with gcc */
299
300 strcpy(dummy_val,val);val = dummy_val;
301
302 var = varTable[ v ];
303
304 if( sscanf(val, "%d", &ival) == 1 )
305 if( ival == 0 ) var->maxi = 0;
306 else var->maxi = 1;
307 else
308 var->maxi = -1;
309
310 if( var->comment )
311 F77_WriteComment( "%s - %s", var->name, var->comment );
312
313 switch( var->type ) {
314 case CONST: bprintf(" %s %s\n",
315 F77_types[ var->baseType ], var->name );
316 bprintf(" PARAMETER ( %s = %s )\n",
317 var->name, val);
318 break;
319 default:
320 printf( "Invalid constant %d", var->type );
321 break;
322 }
323
324 FlushBuf();
325 }
326
327 /*************************************************************************************************/
328 void WriteVecData( VARIABLE * var, int min, int max, int split )
329 {
330 char buf[80];
331 char *p;
332
333 if( split )
334 sprintf( buf, "%6sDATA( %s(i), i = %d, %d ) /\n%5s*",
335 " ", var->name, min, max, " " );
336 else
337 sprintf( buf, "%6sDATA %s /\n%5s*",
338 " ", var->name, " " );
339
340 FlushThisBuf( buf );
341 bprintf( " / \n\n" );
342 FlushBuf();
343 }
344
345 /*************************************************************************************************/
346 void F77_DeclareData( int v, int * values, int n )
347 {
348 int i, j;
349 int nlines, min, max;
350 int split;
351 VARIABLE *var;
352 int * ival;
353 double * dval;
354 char **cval;
355 int maxCols = MAX_COLS;
356 char dsbuf[55];
357
358 var = varTable[ v ];
359 ival = (int*) values;
360 dval = (double*) values;
361 cval = (char**) values;
362
363 nlines = 1;
364 min = max = 1;
365 split = 0;
366
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;
372 case DOUBLE:
373 case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break;
374 case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break;
375 case DOUBLESTRING:
376 strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0';
377 bprintf( "'%48s'", dsbuf ); maxCols=1; break;
378 }
379 if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) {
380 split = 1; nlines = 1;
381 WriteVecData( var, min, max, split );
382 min = max + 1;
383 }
384 else {
385 if( i < n-1 ) bprintf( "," );
386 if( (i+1) % maxCols == 0 ) {
387 bprintf( "\n%5s*", " " );
388 nlines++;
389 }
390 }
391 max ++;
392 }
393 WriteVecData( var, min, max-1, split );
394 break;
395
396 case ELM: bprintf( "%6sDATA %s / ", " ", var->name );
397 switch( var->baseType ) {
398 case INT: bprintf( "%d", *ival ); break;
399 case DOUBLE:
400 case REAL:bprintf( "%lg", *dval ); break;
401 case STRING:bprintf( "'%s'", *cval ); break;
402 case DOUBLESTRING:
403 strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0';
404 bprintf( "'%s'", dsbuf ); maxCols=1; break;
405 /* bprintf( "'%50s'", *cval ); break; */
406 }
407 bprintf( " / \n" );
408 FlushBuf();
409 break;
410 default:
411 printf( "\n Function not defined !\n" );
412 break;
413 }
414 }
415
416 /*************************************************************************************************/
417 void F77_InitDeclare( int v, int n, void * values )
418 {
419 int i;
420 VARIABLE * var;
421
422 var = varTable[ v ];
423 var->maxi = max( n, 1 );
424
425 NewLines(1);
426 F77_DeclareData( v, values, n );
427 }
428
429 /*************************************************************************************************/
430 void F77_FunctionStart( int f, int *vars )
431 {
432 int i;
433 int v;
434 char * name;
435 int narg;
436
437 name = varTable[ f ]->name;
438 narg = varTable[ f ]->maxi;
439
440 bprintf(" SUBROUTINE %s ( ", name );
441 for( i = 0; i < narg-1; i++ ) {
442 v = vars[ i ];
443 bprintf("%s, ", varTable[ v ]->name );
444 }
445 if( narg >= 1 ) {
446 v = vars[ narg-1 ];
447 bprintf("%s ", varTable[ v ]->name );
448 }
449 bprintf(")\n");
450
451 FlushBuf();
452 }
453
454 /*************************************************************************************************/
455 void F77_FunctionPrototipe( int f, ... )
456 {
457 char * name;
458 int narg;
459
460 name = varTable[ f ]->name;
461 narg = varTable[ f ]->maxi;
462
463 bprintf(" EXTERNAL %s\n", name );
464
465 FlushBuf();
466 }
467
468 /*************************************************************************************************/
469 void F77_FunctionBegin( int f, ... )
470 {
471 Va_list args;
472 int i;
473 int v;
474 int vars[20];
475 char * name;
476 int narg;
477 FILE *oldf;
478
479 name = varTable[ f ]->name;
480 narg = varTable[ f ]->maxi;
481
482 Va_start( args, f );
483 for( i = 0; i < narg; i++ )
484 vars[ i ] = va_arg( args, int );
485 va_end( args );
486
487 CommentFncBegin( f, vars );
488 F77_FunctionStart( f, vars );
489 NewLines(1);
490 bprintf(" IMPLICIT NONE\n" );
491 bprintf(" INCLUDE '%s_Parameters.h'\n\n", rootFileName );
492
493 FlushBuf();
494
495 for( i = 0; i < narg; i++ )
496 F77_Declare( vars[ i ] );
497
498 bprintf("\n");
499 FlushBuf();
500
501 MapFunctionComment( f, vars );
502 }
503
504 /*************************************************************************************************/
505 void F77_FunctionEnd( int f )
506 {
507 bprintf(" RETURN\n");
508 bprintf(" END\n\n");
509
510 FlushBuf();
511
512 CommentFunctionEnd( f );
513 }
514
515 /*************************************************************************************************/
516 void F77_Inline( char *fmt, ... )
517 {
518 Va_list args;
519 char buf[ 1000 ];
520
521 if( useLang != F77_LANG ) return;
522
523 Va_start( args, fmt );
524 vsprintf( buf, fmt, args );
525 va_end( args );
526 bprintf( "%s\n", buf );
527
528 FlushBuf();
529 }
530
531 /*************************************************************************************************/
532 void Use_F()
533 {
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;
543
544 FunctionStart = F77_FunctionStart;
545 FunctionPrototipe = F77_FunctionPrototipe;
546 FunctionBegin = F77_FunctionBegin;
547 FunctionEnd = F77_FunctionEnd;
548
549 OpenFile( &param_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" );
562 if ( useStochastic )
563 OpenFile( &stochasticFile, rootFileName, "_Stochastic.f",
564 "The Stochastic Chemical Model File" );
565 if ( useStoicmat ) {
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" );
570 }
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" );
578 }
579 if ( useHessian ) {
580 OpenFile( &hessianFile, rootFileName, "_Hessian.f", "Hessian File" );
581 OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f",
582 "Sparse Hessian Data Structures File" );
583 }
584 OpenFile( &mapFile, rootFileName, ".map",
585 "Map File with Human-Readable Information" );
586 OpenFile( &monitorFile, rootFileName, "_Monitor.f",
587 "Initialization of Utility Data Structures" );
588 }
A coupled weather-fire forecasting model built on top of Weather Research and Forecasting (WRF).