Home


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

source: palm/trunk/UTIL/chemistry/gasphase_preproc/kpp4palm/src/fortran_file.C @ 2696

Last change on this file since 2696 was 2696, checked in by kanani, 6 years ago

Merge of branch palm4u into trunk
File size: 18.9 KB
Line 
1
2// ############################################################################
3//
4//     create_mz_kpp_module                       
5//
6//     create scalar code from .f90 sources created by KPP to be used in MESSy
7//
8//     COPYRIGHT Klaus Ketelsen and MPI-CH   April 2007
9//
10// ############################################################################
11//
12//
13//Current revisions:
14//------------------
15//
16//
17//Former revisions:
18//-----------------
19//$Id: fortran_file.C 2470 2017-09-14 13:56:42Z forkel $
20//
21//
22//changed KPP-generated code to lowercase with uppercase Fortran  expressions
23//added photolysis variables
24//
25//
26//
27//
28// Nov 2016: Intial version (Klaus Ketelsen)
29//
30
31
32#include <fstream>
33#include "fortran_file.h"
34
35#include "utils.h"
36#include "ctype.h"
37void fortran_file::read () {
38
39  ifstream                        in;
40  program_line                    pl;
41  string                          line;
42
43// Note: FORTRAN77 and include files are internally named .f90
44
45  string file_name = name + ".f90";
46  in.open(file_name.c_str() );
47  if( !in ) {
48    cout << "cannot open " << endl; my_abort(file_name);
49  }
50
51// Read kpp_fortran routines;
52  while ( 1 ) {
53     getline(in,line);
54     if( in.eof() ) break;
55     if( in.bad() ) my_abort("ERROR_READ_2");
56
57// Remove trailing blanks
58     while (1) {
59       if(line.size() < 100) break;
60       if(line.substr(line.size()-1,1) != " ")  break;
61       line.erase(line.size()-1,1);
62     }
63
64// Now do some cosmetics to adapt the KPP generated output a bit o the looks of PALM,
65// i.e. add some blanks, convert all to lowercase except Fortran language elements, etc.
66       if(line.find("'",0) == string::npos)  {     // No substitution in line with strings
67        if(line.substr(0,2) =="! ") {
68         global_substitute(line,"#","#");      // just a dummy so comments do not get lost
69         } else {
70         global_substitute(line,"("," ( ");
71         global_substitute(line,")"," ) ");
72         global_substitute(line,",",", ");
73         global_substitute(line,",  ",", ");
74         global_substitute(line,")  ",") ");
75         global_substitute(line,"*","* ");
76         global_substitute(line,"* *","**");
77         global_substitute(line,"/JVS","/ JVS");
78         global_substitute(line,"-","- ");
79         global_substitute(line,"e- ","e-");
80         global_substitute(line,"+","+ ");
81         global_substitute(line,"+  ","+ ");
82         global_substitute(line,"d- ","d-");
83         global_substitute(line,"D- ","D-");
84         global_substitute(line,"e+ ","e+");
85         global_substitute(line,"E+ ","E+");
86         global_substitute(line,"E- ","E-");
87         global_substitute(line,")=",") =");
88         global_subtolower(line);
89         global_substitute(line,"call ","CALL ");
90         global_substitute(line,"case","CASE");
91         global_substitute(line,"character","CHARACTER");
92         global_substitute(line,"contains","CONTAINS");
93         global_substitute(line,"dimension","DIMENSION");
94         global_substitute(line,"do ","DO ");
95         global_substitute(line,"elseif","ELSEIF");
96         global_substitute(line,"else","ELSE");
97         global_substitute(line,"#ELSE","#else");
98         global_substitute(line,"end do","ENDDO");
99         global_substitute(line,"end if","ENDIF");
100         global_substitute(line,"end ","END ");    // Modify "end" after all other strings containing "end..." are done!
101         global_substitute(line,"#ENDIF","#endif");
102         global_substitute(line,"function","FUNCTION");
103         global_substitute(line,"if(","IF (");
104         global_substitute(line," if "," IF ");
105         global_substitute(line,"implicit","IMPLICIT");
106         global_substitute(line,"include","INCLUDE");
107         global_substitute(line,"intent","INTENT");
108         global_substitute(line,"integer","INTEGER");
109         global_substitute(line,"logical","LOGICAL");
110         global_substitute(line,"module","MODULE");
111         global_substitute(line,"none","NONE");
112         global_substitute(line,"optional","OPTIONAL");
113         global_substitute(line,"parameter","PARAMETER");
114         global_substitute(line,"public","PUBLIC");
115         global_substitute(line,"real","REAL");
116         global_substitute(line,"return","RETURN");
117         global_substitute(line,"use ","USE ");
118         global_substitute(line,"save","SAVE");
119         global_substitute(line,"subroutine","SUBROUTINE");
120         global_substitute(line,"then","THEN");
121         global_substitute(line,"while","WHILE");
122       }
123     }
124
125     pl.set_line(line);
126     pline.push_back(pl);
127   }
128   in.close();
129
130  return;
131}
132void fortran_file::edit_fortran () {
133
134  vector<program_line>::iterator     ip;
135  string                             lo_line;
136  bool                               deleted;
137
138  for (ip=pline.begin(); ip != pline.end(); ip++) {
139    if(ip->get_token(0) =="!")   continue;           // No editing of Comments
140    deleted = false;
141    lo_line = ip->get_line() ;
142    if(ip->get_token(0) == "MODULE" && ip->get_token_size() >= 1) {
143      lo_line.insert(0,"!DELETE ");
144    }
145    if(ip->get_token(0) == "USE" && ip->get_token_size() >= 1) {
146      deleted = true;
147      lo_line.insert(0,"!DELETE ");
148    }
149    if(ip->get_token(0) == "PUBLIC" && ip->get_token_size() >= 1) {
150      deleted = true;
151      lo_line.insert(0,"!DELETE ");
152    }
153//    if(ip->get_token(0) == "SAVE" && ip->get_token_size() >= 1) {
154//      lo_line.insert(0,"!DELETE ");
155//    }
156
157//  Only IMPLICIT none, not IMPLICIT REAL (A-H,O-Z)
158    if(ip->get_token(0) == "IMPLICIT" && ip->get_token_size() == 2) {
159      lo_line.insert(0,"!DELETE ");
160    }
161
162//  Delete INCLUDE lines
163    if(ip->get_token(0) == "INCLUDE" && ip->get_token_size() >= 1) {
164      lo_line.insert(0,"!DELETE ");
165    }
166
167//  Update_RCONST has only to be called once per outer timeloop in KPP_FOR_PALM
168
169//  if(ip->get_token(0) == "CALL" && ip->get_token(1) == "Update_RCONST" ) {
170    if(ip->get_token(0) == "CALL" && ip->get_token(1) == "update_rconst" ) {
171      lo_line.insert(0,"!DELETE ");
172    cout << lo_line << endl;
173    }
174
175//  Update_SUN must not be called within in KPP_FOR_PALM
176
177//  if(ip->get_token(0) == "CALL" && ip->get_token(1) == "Update_SUN" ) {
178    if(ip->get_token(0) == "CALL" && ip->get_token(1) == "update_sun" ) {
179      lo_line.insert(0,"!DELETE ");
180    cout << lo_line << endl;
181    }
182
183
184    ip->set_line(lo_line);
185
186//  Delete continuation lines
187
188    if(deleted) {
189      while( ip->get_token_number_from_string("&") > 1) {
190        ip++;
191        lo_line = ip->get_line() ;
192        lo_line.insert(0,"!DELETE ");
193        ip->set_line(lo_line);
194      }
195    }
196  }
197
198  return;
199}
200
201void fortran_file::copy_to_subroutine_vector (vector<fortran_file> &subvec, 
202                                                         fortran_file & header_var) {
203  vector<program_line>::iterator     ip;
204  vector<fortran_file>::iterator     iv;
205  bool                               active_subroutine;
206  string                             active_name;
207  int                                name_pos;
208
209// loop over all lines in a fortran file
210
211
212// First, copy Module variables into header_var
213// This variables wil later copied into the kpp-moduzle header
214
215  for (ip=pline.begin(); ip != pline.end(); ip++) {
216    if(ip->get_token(0) == "CONTAINS")   break;          // Header done
217
218//  Special Treatment of defining variables in PARAMETER context
219//  The intel compiler creates fatal error, if blanks are embedded between / /
220//  The SX-6 Compiler gives a warning
221
222    ip->substitute("( / &","(/&");
223    ip->substitute(",  & !",",& !");
224    ip->substitute(" / )","/)");
225
226
227    header_var.add_line(ip->get_line());
228  }
229
230//  look for SUBROUTINE statement
231  active_subroutine = false;
232
233  for (ip=pline.begin(); ip != pline.end(); ip++) {
234
235//  look for SUBROUTINE statement
236    if(ip->get_token(0) == "SUBROUTINE" && !active_subroutine) {
237
238      for(iv=subvec.begin();iv!=subvec.end();iv++) {
239        if(ip->get_token(1) == iv->get_name() ) { 
240//        Subroutine is in list
241          active_subroutine = true;
242          active_name = ip->get_token(1);
243          cout << "SUBROUTINE: " << active_name << " found in file " << name << endl;
244          break;
245        }
246      }
247    }
248
249//  look for FUNCTION statement
250    name_pos = ip->get_token_number_from_string("FUNCTION");
251    if(name_pos != -1 && !active_subroutine) {
252      name_pos++;
253      for(iv=subvec.begin();iv!=subvec.end();iv++) {
254        if(ip->get_token(name_pos) == iv->get_name() ) { 
255//        Subroutine is in list
256          active_subroutine = true;
257          active_name = ip->get_token(name_pos);
258          cout << "FUNCTION  : " << active_name << " found in file " << name << endl;
259          break;
260        }
261      }
262    }
263
264    if(active_subroutine)  {
265//    copy FORTRAN line from file to subroutine
266      iv->add_line(ip->get_line());
267    }
268    if(ip->get_token(1) == "SUBROUTINE" && ip->get_token(2) == active_name) {
269      cout << "SUBROUTINE: " << active_name << " done " << endl;
270      active_subroutine = false;
271      active_name = " ";
272    }
273    if(ip->get_token(1) == "FUNCTION" && ip->get_token(2) == active_name) {
274      cout << "FUNCTION  : " << active_name << " done " << endl;
275      active_subroutine = false;
276      active_name = " ";
277    }
278  }
279
280  return;
281}
282
283void fortran_file::edit_FUNC () {
284
285  vector<program_line>::iterator     ip;
286  string                             lo_line;
287
288  for (ip=pline.begin(); ip != pline.end(); ip++) {
289    ip->substitute("REAL*8   Y(NVAR), J(LU_NONZERO)","real (kind=8),dimension(:,:)  :: y,j");
290    ip->substitute("REAL*8   Y(NVAR), P(NVAR)",      "real (kind=8),dimension(:,:)  :: y,p");
291    lo_line = ip->get_line() ;
292    if(ip->get_token(0) == "Told" && ip->get_token(1) == "=") {
293      lo_line.insert(0,"!DELETE ");
294    }
295    if(ip->get_token(0) == "TIME" && ip->get_token(1) == "=") {
296      lo_line.insert(0,"!DELETE ");
297    }
298    ip->set_line(lo_line);
299  }
300
301  return;
302}
303
304void fortran_file::edit_inc (fortran_file & header_var) {
305
306  vector<program_line>::iterator     ip;
307  string                             lo_line;
308  string                             lo_line_2;
309  string                             lo_line_3;
310  bool                               deleted;
311  int                                i,nr_var;
312  string                             public_line;
313
314// Delete module and end module lines
315
316  header_var.add_line("! Automatic generated PUBLIC Statements for ip_ and ihs_ variables ");
317  header_var.add_line(" ");
318
319  for (ip=pline.begin(); ip != pline.end(); ip++) {
320    deleted = false;
321    lo_line = ip->get_line() ;
322    if(ip->get_token(0) == "MODULE" && ip->get_token_size() >= 1) {
323      lo_line.insert(0,"!DELETE ");
324    }
325    if(ip->get_token(0) == "END" && ip->get_token_size() >= 1) {
326      lo_line.insert(0,"!DELETE ");
327    }
328    if(ip->get_token(0) == "USE" && ip->get_token_size() >= 1) {
329      deleted = true;
330      lo_line.insert(0,"!DELETE ");
331    }
332    if(ip->get_token(0) == "PUBLIC" && ip->get_token_size() >= 1) {
333      deleted = true;
334      lo_line.insert(0,"!DELETE ");
335    }
336    if(ip->get_token(0) == "SAVE" && ip->get_token_size() >= 1) {
337      lo_line.insert(0,"!DELETE ");
338    }
339
340//  Make ind_ variables public
341    if(ip->get_token(3).substr(0,4) == "ind_") {
342      global_substitute (lo_line,"PARAMETER","PARAMETER, PUBLIC");
343    }
344 
345// Make ip_ variables public
346
347//  mz_rs_20070907+
348// ip_* are already public
349// Make ip_ variables public
350//     nr_var=0;
351//     for(i=0;i<ip->get_token_size();i++) {
352//       if(ip->get_token(i).substr(0,3) == "ip_" && ip->get_token(0).substr(0,1) != "!") {
353//         nr_var++;
354//         if(nr_var == 1)  {
355//           public_line.clear();
356//           public_line = "  PUBLIC  " + ip->get_token(i);
357
358//         } else {
359//           public_line += ", " + ip->get_token(i);
360//         }
361//       }
362//     }
363//     if(nr_var > 0) {
364//       header_var.add_line(public_line);
365//     }
366//  mz_rs_20070907-
367
368// Make ihs_ variables public
369
370    nr_var=0;
371    for(i=0;i<ip->get_token_size();i++) {
372      if(ip->get_token(i).substr(0,4) == "ihs_" && ip->get_token(0).substr(0,1) != "!") {
373        nr_var++;
374        if(nr_var == 1)  {
375          public_line.clear();
376          public_line = "  PUBLIC  " + ip->get_token(i);
377
378        } else {
379          public_line += ", " + ip->get_token(i);
380        }
381      }
382    }
383    if(nr_var > 0) {
384      header_var.add_line(public_line);
385    }
386
387    ip->set_line(lo_line);
388
389//  Delete continuation lines
390
391    if(deleted) {
392      while( ip->get_token_number_from_string("&") > 1) {
393        ip++;
394        lo_line = ip->get_line() ;
395        lo_line.insert(0,"!DELETE ");
396        ip->set_line(lo_line);
397      }
398    }
399  }
400
401  for (ip=pline.begin(); ip != pline.end(); ip++) {
402//  Special Treatment of defining variables in PARAMETER context
403//  The intel compiler creates fatal error, if blanks are embedded between / /
404//  The SX-6 Compiler gives a warning
405
406    if(ip->get_token(7) == "substep" && ip->get_token(9) == "nsubsteps") {
407      ip->substitute("( / 0. / )","0.0");
408    }
409    ip->substitute("( /","(/");
410    ip->substitute("/ )","/)");
411  }
412
413  return;
414}
415
416void fortran_file::create_species_list(vector <string> &species_list) {
417  vector<program_line>::iterator     ip;
418  string                             lo_line;
419  string                             specname;
420  string                             longname;
421
422  bool to_do = false;
423
424  for (ip=pline.begin(); ip != pline.end(); ip++) {
425    if(ip->get_token(2) == "declaration" && ip->get_token(5) == "species") {
426      to_do = true;
427    }
428    if(ip->get_token(5) == "0" && ip->get_token_size() > 5 ) {
429       to_do = false;
430    }
431    if(ip->get_token(0) == "INTEGER," && to_do) {
432      lo_line = ip->get_line() ;
433      int pos = lo_line.find("ind_",0);
434      int end = lo_line.find(" ",pos+1);
435      if(pos > 1) {
436        specname.clear();
437        longname.clear();
438        specname = lo_line.substr(pos+4,end-pos-4);
439        longname = specname + "                 ";
440        //        if(specname != "H2O")  {                     // NO idt_variable for H2O
441          species_list.push_back(specname);
442        //}
443      }
444    }
445  }
446
447  return;
448}
449
450void fortran_file::vector_variable_list(vector <Vvar> &var_list) {
451  vector<program_line>::iterator     ip;
452  string                             lo_line;
453  Vvar                               vari;
454  bool                               todo_1;
455
456  bool to_do = false;
457  for (ip=pline.begin(); ip != pline.end(); ip++) {
458    todo_1 = false;
459    if(ip->get_token(0) == "!KPPPP_DIRECTIVE" && ip->get_token(4) == "start") {
460      to_do = true;
461      ip++;
462    }
463    if(ip->get_token(0) == "!KPPPP_DIRECTIVE" && ip->get_token(4) == "end") {
464       to_do = false;
465    }
466    if(ip->get_token(0).substr(0,1) != "!" && ip->get_token_number_from_string("temp") > 2) {
467//  if(ip->get_token(0).substr(0,1) != "!" && ip->get_token_number_from_string("XXXX") > 2) {
468      todo_1 = true;
469    }
470    if(to_do || todo_1) {
471      if(ip->get_token(0).substr(0,1) == "!") continue;       // skip comment limes
472      vari.clear();
473      int pos1 = ip->get_token_number_from_string_upper ("DimensioN");
474      int pos  = ip->get_token_number_from_string("::");
475      vari.name = ip->get_token(pos+1);
476      if(pos1 > 1) {
477        for (int i=pos1+2; i< ip->get_token_size(); i++) {
478          if(ip->get_token(i).substr(0,1) == "!" || ip->get_token(i) == ")" ) {
479            break;
480          } else {
481            ip->substitute(","," "); 
482            vari.dim_var.push_back(ip->get_token(i));
483          }
484        }
485      } else {
486        if(ip->get_token_size() > pos+1 && ip->get_token(pos+2).substr(0,1) != "!" 
487                          && ip->get_token(pos+2).substr(0,1) != "=" )  {
488          for (int i=pos+3; i< ip->get_token_size(); i++) {
489            if(ip->get_token(i).substr(0,1) == "!" || ip->get_token(i) == ")" ) {
490              break;
491            } else {
492              ip->substitute(","," "); 
493              vari.dim_var.push_back(ip->get_token(i));
494            }
495          }
496        }
497      }
498      var_list.push_back(vari);
499      cout << "Vector variable " << ip->get_token(pos+1) <<" " << vari.nr_dim() <<endl;
500      lo_line = ip->get_line() ;
501      if(vari.nr_dim() == 0) {
502        lo_line.clear();
503        lo_line = "  REAL(dp),dimension(:),allocatable             :: " + vari.name;
504      }
505      if(vari.nr_dim() == 1) {
506        lo_line.clear();
507        lo_line = "  REAL(dp),dimension(:,:),allocatable           :: " + vari.name;
508      }
509      if(vari.nr_dim() == 2) {
510        lo_line.clear();
511        lo_line = "  REAL(dp),dimension(:,:,:),allocatable         :: " + vari.name;
512      }
513      if(vari.nr_dim() == 3) {
514        lo_line.clear();
515        lo_line = "  REAL(dp),dimension(:,:,:,:),allocatable       :: " + vari.name;
516      }
517      ip->set_line(lo_line);
518    }
519  }
520
521  return;
522}
523
524void fortran_file::print () {
525
526  vector<program_line>::iterator     ip;
527
528  cout << " " <<endl;
529  cout << "FORTRAN file " << name << endl;
530
531  for (ip=pline.begin(); ip != pline.end(); ip++) {
532    cout << ip->get_line() <<endl;
533  }
534
535  cout << " " <<endl;
536
537  return;
538}
539
540void fortran_file::write_file (ofstream & out) {
541
542  vector<program_line>::iterator     ip;
543  string                             lo_line;
544
545  for (ip=pline.begin(); ip != pline.end(); ip++) {
546    ip->global_substitute(" ( ","(");
547    ip->global_substitute(" ) ",")");
548    ip->global_substitute(" )",")");
549    ip->global_substitute("A (","A(");
550    ip->global_substitute("B (","B(");
551    ip->global_substitute("V (","V(");
552    ip->global_substitute("Vdot (","Vdot(");
553    ip->global_substitute("JVS (","JVS(");
554    ip->global_substitute("RCT (","RCT(");
555    ip->global_substitute("* ","*");
556    ip->global_substitute("* ","*");
557    ip->global_substitute("d- ","d-");
558    ip->global_substitute("d+ ","d+");
559    ip->global_substitute(", ",",");
560    ip->global_substitute(")=",") =");
561    ip->global_substitute("dp,","dp, ");
562    ip->global_substitute(", - ",", -");
563
564//  line break if more than 130 character
565
566    lo_line = ip->get_line();
567    if( lo_line.size() < 130 ) {
568      out << ip->get_line() <<endl;
569    } else {
570      int cp  = lo_line.rfind("!",129);
571      int pos = lo_line.rfind(" ",129);
572      out << lo_line.substr(0,pos) << " &"<<endl;
573      lo_line.erase (0,pos);
574      if(ip->get_token (0).substr(0,1)  == "!" || cp != string::npos ) {
575        out << "!   " << lo_line   <<endl;                 // comment also in next line
576      } else {
577        out << "                    " << lo_line   <<endl;
578      }
579    }
580  }
581
582  out << " " <<endl;
583
584  return;
585}
586
587void fortran_file::copy_to_MZ_KPP (fortran_file & ka) {
588
589  vector<program_line>::iterator     ip;
590
591  for (ip=pline.begin(); ip != pline.end(); ip++) {
592//  Do not copy lines marked for delete
593    if(ip->get_token(0) != "!DELETE") {
594      ka.add_line( ip->get_line() );
595    }
596  }
597
598  return;
599}
600void  fortran_file::global_substitute(string &line, string old_s, string new_s) {
601   int         pos;
602
603   int start = line.size()-1;
604
605   while (1) {
606     pos = line.rfind (old_s, start);       // look for string
607
608     if (pos == string::npos) {
609       break;
610     }
611
612     line.replace(pos,old_s.size(),new_s);
613
614     start = pos-1;
615   }
616
617   return;
618}
619
620void  fortran_file::global_subtolower(string &line) {
621
622   int start = line.size()-1;
623   char c;
624
625    int i = 0;
626    while (line[i])
627    {
628      c = line[i];
629      line[i] = tolower(c);
630      i++;
631    }
632   return;
633}
Note: See TracBrowser for help on using the repository browser.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |