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 @ 3950

Last change on this file since 3950 was 3799, checked in by forkel, 6 years ago

editing in kpp4palm: add statements for avoiding unused variables, remove $Id
File size: 27.2 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//Former revisions:
14//-----------------
15// Deleted $Id since document_changes does not work for C and C++   (15.03.2019, forkel)
16//
17// For vector version edit phot(nphot) - was before done in kpp4pal.ksh (15.03.2019, forkel)
18//
19// OpenMP version    (15.03.2019, ketelsen)
20//
21// removal of unnecessary variables (Ntotal, TSTART)   (08.03.2019 forkel)
22//
23// Added vector switch and creation of dimension statement (rev. 3260, 18.09.2018, ketelsen)
24//
25// removal of unnecessary variables (LOOKAT, monitor etc. from Fortran code) (Sept.2018, forkel)
26//
27// Replace Roundoff = WLAMCH('E') by Roundoff = epsilon(one)   (20.04.2018, forkel)
28//
29// Moved adaption to PALM conventions to the end of the processing kpp output
30//  in order to make future use of vector code adaptations possible (June 2018, forkel)
31//
32// changed KPP-generated code to lowercase with uppercase Fortran  expressions
33// added photolysis variables                               (2017-09-14, forkel)
34//
35// Initial version of KP4 adapted to PALM                   (Nov 2016, ketelsen)
36//
37
38
39#include <fstream>
40#include "fortran_file.h"
41
42#include "utils.h"
43#include "ctype.h"
44void fortran_file::read () {
45
46  ifstream                        in;
47  program_line                    pl;
48  string                          line;
49
50// Note: FORTRAN77 and include files are internally named .f90
51
52  string file_name = name + ".f90";
53  in.open(file_name.c_str() );
54  if( !in ) {
55    cout << "cannot open " << endl; my_abort(file_name);
56  }
57
58// Read kpp_fortran routines;
59  while ( 1 ) {
60     getline(in,line);
61     if( in.eof() ) break;
62     if( in.bad() ) my_abort("ERROR_READ_2");
63
64// Remove trailing blanks
65     while (1) {
66       if(line.size() < 100) break;
67       if(line.substr(line.size()-1,1) != " ")  break;
68       line.erase(line.size()-1,1);
69     }
70
71     if(line.find("'",0) == string::npos)  {     // No substitution in line with strings
72//     if(line.substr(0,4) !="!KPP") {
73//      global_substitute(line,"!"," ! ");
74//     if(line.substr(0,2) =="! ")   continue;           // No Substitute of Comments
75//     global_substitute(line,"("," ( ");
76//     global_substitute(line,")"," ) ");
77//     global_substitute(line,",",", ");
78//     global_substitute(line,"*","* ");
79//     global_substitute(line,"* *","**");
80//     global_substitute(line,"/JVS","/ JVS");
81//     global_substitute(line,"-","- ");
82//     global_substitute(line,"e- ","e-");
83//     global_substitute(line,"+","+ ");
84//     global_substitute(line,"d- ","d-");
85//     global_substitute(line,"D- ","D-");
86//     global_substitute(line,"e+ ","e+");
87//     global_substitute(line,"E+ ","E+");
88//     global_substitute(line,"E- ","E-");
89//      }
90
91        if(line.substr(0,2) =="! ") {
92         global_substitute(line,"#","#");      // just a dummy so comments do not get lost
93         } else {
94         global_substitute(line,"("," ( ");
95         global_substitute(line,")"," ) ");
96         global_substitute(line,",",", ");
97         global_substitute(line,",  ",", ");
98         global_substitute(line,")  ",") ");
99         global_substitute(line,"*","* ");
100         global_substitute(line,"* *","**");
101         global_substitute(line,"/JVS","/ JVS");
102         global_substitute(line,"-","- ");
103         global_substitute(line,"+","+ ");
104         global_substitute(line,"+  ","+ ");
105         }
106     }
107
108     pl.set_line(line);
109     pline.push_back(pl);
110   }
111   in.close();
112
113  return;
114}
115void fortran_file::edit_fortran () {
116
117  vector<program_line>::iterator     ip;
118  string                             lo_line;
119  bool                               deleted;
120
121  for (ip=pline.begin(); ip != pline.end(); ip++) {
122    if(ip->get_token(0) =="!")   continue;           // No editing of Comments
123    deleted = false;
124    lo_line = ip->get_line() ;
125    if(ip->get_token(0) == "MODULE" && ip->get_token_size() >= 1) {
126      lo_line.insert(0,"!DELETE ");
127    }
128    if(ip->get_token(0) == "USE" && ip->get_token_size() >= 1) {
129      deleted = true;
130      lo_line.insert(0,"!DELETE ");
131    }
132    if(ip->get_token(0) == "PUBLIC" && ip->get_token_size() >= 1) {
133      deleted = true;
134      lo_line.insert(0,"!DELETE ");
135    }
136//    if(ip->get_token(0) == "SAVE" && ip->get_token_size() >= 1) {
137//      lo_line.insert(0,"!DELETE ");
138//    }
139
140//  Only IMPLICIT none, not IMPLICIT REAL (A-H,O-Z)
141    if(ip->get_token(0) == "IMPLICIT" && ip->get_token_size() == 2) {
142      lo_line.insert(0,"!DELETE ");
143    }
144
145//  Delete INCLUDE lines
146    if(ip->get_token(0) == "INCLUDE" && ip->get_token_size() >= 1) {
147      lo_line.insert(0,"!DELETE ");
148    }
149
150//  Update_RCONST has only to be called once per outer timeloop in KPP_FOR_PALM
151
152    if(ip->get_token(0) == "CALL" && ip->get_token(1) == "Update_RCONST" ) {
153      lo_line.insert(0,"!DELETE ");
154    cout << lo_line << endl;
155    }
156
157//  Update_SUN must not be called within in KPP_FOR_PALM
158
159    if(ip->get_token(0) == "CALL" && ip->get_token(1) == "Update_SUN" ) {
160      lo_line.insert(0,"!DELETE ");
161    cout << lo_line << endl;
162    }
163
164//  Remove "    var(i) = x"  (Make sure  that var does not occur as first token anywhere else)
165
166    if(ip->get_token(0) == "VAR") {
167      lo_line.insert(0,"!DELETE ");
168    cout << lo_line << endl;
169    }
170
171//  Remove Ntotal since it is unused
172
173    if(ip->get_token(3) == "Ntotal") {
174      lo_line.insert(0,"!DELETE ");
175    cout << lo_line << endl;
176    }
177
178
179
180    ip->set_line(lo_line);
181
182//  Delete continuation lines
183
184    if(deleted) {
185      while( ip->get_token_number_from_string("&") > 1) {
186        ip++;
187        lo_line = ip->get_line() ;
188        lo_line.insert(0,"!DELETE ");
189        ip->set_line(lo_line);
190      }
191    }
192  }
193
194  return;
195}
196
197void fortran_file::copy_to_subroutine_vector (vector<fortran_file> &subvec, 
198                                                         fortran_file & header_var) {
199  vector<program_line>::iterator     ip;
200  vector<fortran_file>::iterator     iv;
201  bool                               active_subroutine;
202  string                             active_name;
203  int                                name_pos;
204
205// loop over all lines in a fortran file
206
207
208// First, copy Module variables into header_var
209// This variables wil later copied into the kpp-moduzle header
210
211  for (ip=pline.begin(); ip != pline.end(); ip++) {
212    if(ip->get_token(0) == "CONTAINS")   break;          // Header done
213
214//  Special Treatment of defining variables in PARAMETER context
215//  The intel compiler creates fatal error, if blanks are embedded between / /
216//  The SX-6 Compiler gives a warning
217
218    ip->substitute("( / &","(/&");
219    ip->substitute(",  & !",",& !");
220    ip->substitute(" / )","/)");
221
222
223    header_var.add_line(ip->get_line());
224  }
225
226//  look for SUBROUTINE statement
227  active_subroutine = false;
228
229  for (ip=pline.begin(); ip != pline.end(); ip++) {
230
231//  look for SUBROUTINE statement
232    if(ip->get_token(0) == "SUBROUTINE" && !active_subroutine) {
233
234      for(iv=subvec.begin();iv!=subvec.end();iv++) {
235        if(ip->get_token(1) == iv->get_name() ) { 
236//        Subroutine is in list
237          active_subroutine = true;
238          active_name = ip->get_token(1);
239          cout << "SUBROUTINE: " << active_name << " found in file " << name << endl;
240          break;
241        }
242      }
243    }
244
245//  look for FUNCTION statement
246    name_pos = ip->get_token_number_from_string("FUNCTION");
247    if(name_pos != -1 && !active_subroutine) {
248      name_pos++;
249      for(iv=subvec.begin();iv!=subvec.end();iv++) {
250        if(ip->get_token(name_pos) == iv->get_name() ) { 
251//        Subroutine is in list
252          active_subroutine = true;
253          active_name = ip->get_token(name_pos);
254          cout << "FUNCTION  : " << active_name << " found in file " << name << endl;
255          break;
256        }
257      }
258    }
259
260    if(active_subroutine)  {
261//    copy FORTRAN line from file to subroutine
262      iv->add_line(ip->get_line());
263    }
264    if(ip->get_token(1) == "SUBROUTINE" && ip->get_token(2) == active_name) {
265      cout << "SUBROUTINE: " << active_name << " done " << endl;
266      active_subroutine = false;
267      active_name = " ";
268    }
269    if(ip->get_token(1) == "FUNCTION" && ip->get_token(2) == active_name) {
270      cout << "FUNCTION  : " << active_name << " done " << endl;
271      active_subroutine = false;
272      active_name = " ";
273    }
274  }
275
276  return;
277}
278
279void fortran_file::edit_FUNC () {
280
281  vector<program_line>::iterator     ip;
282  string                             lo_line;
283
284  for (ip=pline.begin(); ip != pline.end(); ip++) {
285    ip->substitute("REAL*8   Y(NVAR), J(LU_NONZERO)","real (kind=8),dimension(:,:)  :: y,j");
286    ip->substitute("REAL*8   Y(NVAR), P(NVAR)",      "real (kind=8),dimension(:,:)  :: y,p");
287    lo_line = ip->get_line() ;
288    if(ip->get_token(0) == "Told" && ip->get_token(1) == "=") {
289      lo_line.insert(0,"!DELETE ");
290    }
291    if(ip->get_token(0) == "TIME" && ip->get_token(1) == "=") {
292      lo_line.insert(0,"!DELETE ");
293    }
294    ip->set_line(lo_line);
295  }
296
297  return;
298}
299
300void fortran_file::edit_inc (fortran_file & header_var) {
301
302  vector<program_line>::iterator     ip;
303  string                             lo_line;
304  string                             lo_line_2;
305  string                             lo_line_3;
306  bool                               deleted;
307  int                                i,nr_var;
308  string                             public_line;
309
310// Delete module and end module lines
311
312  header_var.add_line("! Automatic generated PUBLIC Statements for ip_ and ihs_ variables ");
313  header_var.add_line(" ");
314
315  for (ip=pline.begin(); ip != pline.end(); ip++) {
316    deleted = false;
317    lo_line = ip->get_line() ;
318    if(ip->get_token(0) == "MODULE" && ip->get_token_size() >= 1) {
319      lo_line.insert(0,"!DELETE ");
320    }
321    if(ip->get_token(0) == "END" && ip->get_token_size() >= 1) {
322      lo_line.insert(0,"!DELETE ");
323    }
324    if(ip->get_token(0) == "USE" && ip->get_token_size() >= 1) {
325      deleted = true;
326      lo_line.insert(0,"!DELETE ");
327    }
328    if(ip->get_token(0) == "PUBLIC" && ip->get_token_size() >= 1) {
329      deleted = true;
330      lo_line.insert(0,"!DELETE ");
331    }
332    if(ip->get_token(0) == "SAVE" && ip->get_token_size() >= 1) {
333      lo_line.insert(0,"!DELETE ");
334    }
335//  Delete KPP-generated EQUIVALENCE line (var is POINTER now)
336    if(ip->get_token(0) == "EQUIVALENCE"  && ip->get_token_size() >= 1) {
337      lo_line.insert(0,"!DELETE ");
338    }
339
340//  Remove  REAL(kind=dp):: sun
341
342    if(ip->get_token_number_from_string("SUN") > 0) {
343      lo_line.insert(0,"!DELETE ");
344    cout << lo_line << endl;
345    }
346
347//  Remove    INTEGER :: ddmtype
348
349    if(ip->get_token_number_from_string("DDMTYPE") > 0) {
350    cout << lo_line << endl;
351      lo_line.insert(0,"!DELETE ");
352    cout << lo_line << endl;
353    }
354
355//  Remove    REAL(kind=dp) :: dt
356
357    if(ip->get_token_number_from_string("DT") > 0) {
358    cout << lo_line << endl;
359      lo_line.insert(0,"!DELETE ");
360    cout << lo_line << endl;
361    }
362
363//  Remove    LOOKAT
364
365    if(ip->get_token_number_from_string("LOOKAT") > 0) {
366    cout << lo_line << endl;
367      lo_line.insert(0,"!DELETE ");
368    cout << lo_line << endl;
369    }
370
371//  Remove    NLOOKAT
372
373    if(ip->get_token_number_from_string("NLOOKAT") > 0) {
374    cout << lo_line << endl;
375      lo_line.insert(0,"!DELETE ");
376    cout << lo_line << endl;
377    }
378
379//  Remove    MONITOR
380
381    if(ip->get_token_number_from_string("MONITOR") > 0) {
382    cout << lo_line << endl;
383      lo_line.insert(0,"!DELETE ");
384    cout << lo_line << endl;
385    }
386
387//  Remove    NMONITOR
388
389    if(ip->get_token_number_from_string("NMONITOR") > 0) {
390    cout << lo_line << endl;
391      lo_line.insert(0,"!DELETE ");
392    cout << lo_line << endl;
393    }
394
395//  Remove    SMASS
396
397    if(ip->get_token_number_from_string("SMASS") > 0) {
398    cout << lo_line << endl;
399      lo_line.insert(0,"!DELETE ");
400    cout << lo_line << endl;
401    }
402
403//  Remove    RTOLS
404
405    if(ip->get_token_number_from_string("RTOLS") > 0) {
406    cout << lo_line << endl;
407      lo_line.insert(0,"!DELETE ");
408    cout << lo_line << endl;
409    }
410
411//  Remove    TSTART
412
413    if(ip->get_token_number_from_string("TSTART") > 0) {
414    cout << lo_line << endl;
415      lo_line.insert(0,"!DELETE ");
416    cout << lo_line << endl;
417    }
418
419//  Remove    TEND
420
421    if(ip->get_token_number_from_string("TEND") > 0) {
422    cout << lo_line << endl;
423      lo_line.insert(0,"!DELETE ");
424    cout << lo_line << endl;
425    }
426
427//  Remove    STEPMAX
428
429    if(ip->get_token_number_from_string("STEPMAX") > 0) {
430    cout << lo_line << endl;
431      lo_line.insert(0,"!DELETE ");
432    cout << lo_line << endl;
433    }
434
435//  Make ind_ variables public
436
437    if(ip->get_token(3).substr(0,4) == "ind_") {
438      global_substitute (lo_line,"PARAMETER","PARAMETER, PUBLIC");
439    }
440 
441// Make ip_ variables public
442
443//  mz_rs_20070907+
444// ip_* are already public
445// Make ip_ variables public
446//     nr_var=0;
447//     for(i=0;i<ip->get_token_size();i++) {
448//       if(ip->get_token(i).substr(0,3) == "ip_" && ip->get_token(0).substr(0,1) != "!") {
449//         nr_var++;
450//         if(nr_var == 1)  {
451//           public_line.clear();
452//           public_line = "  PUBLIC  " + ip->get_token(i);
453
454//         } else {
455//           public_line += ", " + ip->get_token(i);
456//         }
457//       }
458//     }
459//     if(nr_var > 0) {
460//       header_var.add_line(public_line);
461//     }
462//  mz_rs_20070907-
463
464// Make ihs_ variables public
465
466    nr_var=0;
467    for(i=0;i<ip->get_token_size();i++) {
468      if(ip->get_token(i).substr(0,4) == "ihs_" && ip->get_token(0).substr(0,1) != "!") {
469        nr_var++;
470        if(nr_var == 1)  {
471          public_line.clear();
472          public_line = "  PUBLIC  " + ip->get_token(i);
473
474        } else {
475          public_line += ", " + ip->get_token(i);
476        }
477      }
478    }
479    if(nr_var > 0) {
480      header_var.add_line(public_line);
481    }
482
483    ip->set_line(lo_line);
484
485//  Delete continuation lines
486
487    if(deleted) {
488      while( ip->get_token_number_from_string("&") > 1) {
489        ip++;
490        lo_line = ip->get_line() ;
491        lo_line.insert(0,"!DELETE ");
492        ip->set_line(lo_line);
493      }
494    }
495  }
496
497  for (ip=pline.begin(); ip != pline.end(); ip++) {
498//  Special Treatment of defining variables in PARAMETER context
499//  The intel compiler creates fatal error, if blanks are embedded between / /
500//  The SX-6 Compiler gives a warning
501
502    if(ip->get_token(7) == "substep" && ip->get_token(9) == "nsubsteps") {
503      ip->substitute("( / 0. / )","0.0");
504    }
505    ip->substitute("( /","(/");
506    ip->substitute("/ )","/)");
507  }
508
509  return;
510}
511
512void fortran_file::create_species_list(vector <string> &species_list) {
513  vector<program_line>::iterator     ip;
514  string                             lo_line;
515  string                             specname;
516  string                             longname;
517
518  bool to_do = false;
519
520  for (ip=pline.begin(); ip != pline.end(); ip++) {
521    if(ip->get_token(2) == "declaration" && ip->get_token(5) == "species") {
522      to_do = true;
523    }
524    if(ip->get_token(5) == "0" && ip->get_token_size() > 5 ) {
525       to_do = false;
526    }
527    if(ip->get_token(0) == "INTEGER," && to_do) {
528      lo_line = ip->get_line() ;
529      int pos = lo_line.find("ind_",0);
530      int end = lo_line.find(" ",pos+1);
531      if(pos > 1) {
532        specname.clear();
533        longname.clear();
534        specname = lo_line.substr(pos+4,end-pos-4);
535        longname = specname + "                 ";
536        //        if(specname != "H2O")  {                     // NO idt_variable for H2O
537          species_list.push_back(specname);
538        //}
539      }
540    }
541  }
542
543  return;
544}
545
546void fortran_file::vector_variable_list(vector <Vvar> &var_list) {
547  vector<program_line>::iterator     ip;
548  string                             lo_line;
549  Vvar                               vari;
550  bool                               todo_1;
551
552  bool to_do = false;
553  for (ip=pline.begin(); ip != pline.end(); ip++) {
554    todo_1 = false;
555    if(ip->get_token(0) == "!KPPPP_DIRECTIVE" && ip->get_token(4) == "start") {
556      to_do = true;
557      ip++;
558    }
559    if(ip->get_token(0) == "!KPPPP_DIRECTIVE" && ip->get_token(4) == "end") {
560       to_do = false;
561    }
562    if(kpp_switches.is_vector()) {
563       if(ip->get_token(0).substr(0,1) != "!" && ip->get_token_number_from_string("TEMP") > 2) {
564         todo_1 = true;
565       }
566       if(ip->get_token(0).substr(0,1) != "!" && ip->get_token_number_from_string("QVAP") > 2) {
567         todo_1 = true;
568       }
569       if(ip->get_token(0).substr(0,1) != "!" && ip->get_token_number_from_string("FAKT") > 2) {
570         todo_1 = true;
571       }
572    }
573
574    if(to_do || todo_1) {
575      if(ip->get_token(0).substr(0,1) == "!") continue;       // skip comment limes
576      vari.clear();
577      int pos1 = ip->get_token_number_from_string_upper ("DimensioN");
578      int pos  = ip->get_token_number_from_string("::");
579      vari.name = ip->get_token(pos+1);
580      if(pos1 > 1) {
581        for (int i=pos1+2; i< ip->get_token_size(); i++) {
582          if(ip->get_token(i).substr(0,1) == "!" || ip->get_token(i) == ")" ) {
583            break;
584          } else {
585            ip->substitute(","," "); 
586            vari.dim_var.push_back(ip->get_token(i));
587          }
588        }
589      } else {
590        if(ip->get_token_size() > pos+1 && ip->get_token(pos+2).substr(0,1) != "!" 
591                          && ip->get_token(pos+2).substr(0,1) != "=" )  {
592          for (int i=pos+3; i< ip->get_token_size(); i++) {
593            if(ip->get_token(i).substr(0,1) == "!" || ip->get_token(i) == ")" ) {
594              break;
595            } else {
596              ip->substitute(","," "); 
597              vari.dim_var.push_back(ip->get_token(i));
598            }
599          }
600        }
601      }
602      var_list.push_back(vari);
603      cout << "Vector variable " << ip->get_token(pos+1) <<" " << vari.nr_dim() <<endl;
604      lo_line = ip->get_line() ;
605      if(todo_1)   {
606          lo_line.clear();
607          lo_line = "  REAL(dp),dimension(VL_DIM)                  :: " + vari.name;
608      } else {
609         if(vari.nr_dim() == 0) {
610           lo_line.clear();
611           lo_line = "  REAL(dp),dimension(:),allocatable             :: " + vari.name;
612         }
613         if(vari.nr_dim() == 1) {
614           lo_line.clear();
615           lo_line = "  REAL(dp),dimension(:,:),allocatable           :: " + vari.name;
616         }
617         if(vari.nr_dim() == 2) {
618           lo_line.clear();
619           lo_line = "  REAL(dp),dimension(:,:,:),allocatable         :: " + vari.name;
620         }
621         if(vari.nr_dim() == 3) {
622           lo_line.clear();
623           lo_line = "  REAL(dp),dimension(:,:,:,:),allocatable       :: " + vari.name;
624         }
625      }
626      ip->set_line(lo_line);
627    }
628  }
629
630  return;
631}
632
633void fortran_file::print () {
634
635  vector<program_line>::iterator     ip;
636
637  cout << " " <<endl;
638  cout << "FORTRAN file " << name << endl;
639
640  for (ip=pline.begin(); ip != pline.end(); ip++) {
641    cout << ip->get_line() <<endl;
642  }
643
644  cout << " " <<endl;
645
646  return;
647}
648
649void fortran_file::write_file (ofstream & out) {
650
651  vector<program_line>::iterator     ip;
652  program_line                    pl;
653  string                             lo_line;
654  string                             line;
655
656  for (ip=pline.begin(); ip != pline.end(); ip++) {
657    ip->global_substitute(" ( ","(");
658    ip->global_substitute(" ) ",")");
659    ip->global_substitute(" )",")");
660    ip->global_substitute("A (","A(");
661    ip->global_substitute("B (","B(");
662    ip->global_substitute("V (","V(");
663    ip->global_substitute("Vdot (","Vdot(");
664    ip->global_substitute("JVS (","JVS(");
665    ip->global_substitute("RCT (","RCT(");
666    ip->global_substitute("* ","*");
667    ip->global_substitute("* ","*");
668//  ip->global_substitute("d- ","d-");
669//  ip->global_substitute("d+ ","d+");
670    ip->global_substitute(", ",",");
671    ip->global_substitute(")=",") =");
672    ip->global_substitute("dp,","dp, ");
673    ip->global_substitute(", - ",", -");
674
675//  Replace Roundoff = WLAMCH('E') since WLAMCH does not work everywhere
676       ip->global_substitute("Roundoff = WLAMCH('E')","roundoff = epsilon(one)");
677//  For vector version edit  phot(nphot) from INLINE in chem_gasphase_mod.kpp
678    if(kpp_switches.is_vector()) {
679        ip->global_substitute("phot(nphot)","phot(vl_dim,nphot)");
680    }
681
682// Now do some cosmetics to adapt the KPP generated output a bit o the looks of PALM,
683// i.e. add some blanks, convert all to lowercase except Fortran language elements, etc.
684       lo_line = ip->get_line();
685       if(lo_line.find("'",0) == string::npos)  {     // No substitution in line with strings
686        if(lo_line.substr(0,2) =="! ") {
687         ip->global_substitute("#","#");      // just a dummy so comments do not get lost
688         } else {
689//       cout << "HIER0 " << lo_line <<endl;
690//       global_substitute(lo_line,"("," ( ");
691//       global_substitute(lo_line,")"," ) ");
692         global_substitute(lo_line,",",", ");
693         global_substitute(lo_line,",  ",", ");
694         global_substitute(lo_line,")  ",") ");
695         global_substitute(lo_line,"*","* ");
696         global_substitute(lo_line,"* *","**");
697         global_substitute(lo_line,")+",") +");
698         global_substitute(lo_line,")-",") -");
699         global_substitute(lo_line,")/",") /");
700         global_substitute(lo_line,")*",") *");
701         global_substitute(lo_line,")=",") =");
702//       global_substitute(lo_line,"-","- ");
703         global_substitute(lo_line,"-  ","- ");
704         global_substitute(lo_line,"+","+ ");
705         global_substitute(lo_line,"+  ","+ ");
706         global_substitute(lo_line,"=- ","= -");
707         global_substitute(lo_line,"/JVS","/ JVS");
708         global_substitute(lo_line,"d- ","d-");
709         global_substitute(lo_line,"d+ ","d+");
710         global_substitute(lo_line,"D- ","D-");
711         global_substitute(lo_line,"D+ ","D+");
712         global_substitute(lo_line,"e- ","e-");
713         global_substitute(lo_line,"e+ ","e+");
714         global_substitute(lo_line,"E+ ","E+");
715         global_substitute(lo_line,"E- ","E-");
716//   Set all characters to lowercase
717         ip->global_subtolower(lo_line);
718//   Restore OMP directives: The next 2 lines are not only cosmetics!
719         global_substitute(lo_line,"!$omp","!$OMP");
720         global_substitute(lo_line,"threadprivate","THREADPRIVATE");
721
722         global_substitute(lo_line,"allocated","ALLOCATED");
723         global_substitute(lo_line,"allocatable","ALLOCATABLE");
724         global_substitute(lo_line,".and. ",".AND. ");
725         global_substitute(lo_line,"call ","CALL ");
726         global_substitute(lo_line,"case","CASE");
727         global_substitute(lo_line,"character","CHARACTER");
728         global_substitute(lo_line,"contains","CONTAINS");
729         global_substitute(lo_line,"contiguous","CONTIGUOUS");
730         global_substitute(lo_line,"deallocate","DEALLOCATE");
731         global_substitute(lo_line,"allocate","ALLOCATE");
732         global_substitute(lo_line,"dimension","DIMENSION");
733         global_substitute(lo_line,"do ","DO ");
734         global_substitute(lo_line,"elseif","ELSEIF");
735         global_substitute(lo_line,"else","ELSE");
736         global_substitute(lo_line,"#ELSE","#else");
737         global_substitute(lo_line,"end do","ENDDO");
738         global_substitute(lo_line,"end if","ENDIF");
739         global_substitute(lo_line,"endif","ENDIF");
740         global_substitute(lo_line,"endwhere","ENDWHERE");
741         global_substitute(lo_line,"end ","END ");    // Modify "end" after all other strings containing "end..." are done!
742         global_substitute(lo_line,"tEND","tend");
743         global_substitute(lo_line,"#ENDIF","#endif");
744         global_substitute(lo_line,"function","FUNCTION");
745         global_substitute(lo_line,"if(","IF (");
746         global_substitute(lo_line," if "," IF ");
747         global_substitute(lo_line,"implicit","IMPLICIT");
748         global_substitute(lo_line,"include","INCLUDE");
749         global_substitute(lo_line,"intent","INTENT");
750         global_substitute(lo_line,"integer","INTEGER");
751         global_substitute(lo_line,"interface","INTERFACE");
752         global_substitute(lo_line,"logical","LOGICAL");
753         global_substitute(lo_line,"module","MODULE");
754         global_substitute(lo_line,"none","NONE");
755         global_substitute(lo_line,"only","ONLY");
756         global_substitute(lo_line,"optional","OPTIONAL");
757         global_substitute(lo_line,"parameter","PARAMETER");
758         global_substitute(lo_line,"pointer","POINTER");
759         global_substitute(lo_line,"present","PRESENT");
760         global_substitute(lo_line,"private","PRIVATE");
761         global_substitute(lo_line,"procedure","PROCEDURE");
762         global_substitute(lo_line,"public","PUBLIC");
763         global_substitute(lo_line,"real","REAL");
764         global_substitute(lo_line,"return","RETURN");
765         global_substitute(lo_line,"use ","USE ");
766         global_substitute(lo_line,"save","SAVE");
767         global_substitute(lo_line,"subroutine","SUBROUTINE");
768         global_substitute(lo_line,"target","TARGET");
769         global_substitute(lo_line,"then","THEN");
770         global_substitute(lo_line,"where","WHERE");
771         global_substitute(lo_line,"while","WHILE");
772         global_substitute(lo_line,".false.",".FALSE.");
773         global_substitute(lo_line,".true.",".TRUE.");
774         global_substitute(lo_line,"(in)","(IN)");
775         global_substitute(lo_line,"(out)","(OUT)");
776         global_substitute(lo_line,"(inout)","(INOUT)");
777         global_substitute(lo_line,"\t","      ");
778
779         // Skalar Version
780         global_substitute(lo_line,"  REAL(kind=dp):: var(nvar)","! REAL(kind=dp):: var(nvar)  var is now POINTER");
781         global_substitute(lo_line,"REAL(kind=dp):: c(nspec)","REAL(kind=dp), TARGET    :: c(nspec)");
782         // Vektor Version
783         global_substitute(lo_line,"  REAL(kind=dp):: var (vl_dim, nvar)","! REAL(kind=dp):: var (vl_dim, nvar)  var is now POINTER");
784         global_substitute(lo_line,"REAL(kind=dp):: c (vl_dim, nspec)","REAL(kind=dp), TARGET    :: c (vl_dim, nspec)");
785
786//       cout << "HIER1 " << lo_line <<endl;
787       }
788     }
789//   pl.set_line(lo_line);
790//   pline.push_back(pl);
791
792
793//  line break if more than 130 character
794
795//  lo_line = ip->get_line();
796    if( lo_line.size() < 130 ) {
797//    out << ip->get_line() <<endl;
798      out <<  lo_line    <<endl;
799    } else {
800      int cp  = lo_line.rfind("!",129);
801      int pos = lo_line.rfind(" ",129);
802      out << lo_line.substr(0,pos) << " &"<<endl;
803      lo_line.erase (0,pos);
804      if(ip->get_token (0).substr(0,1)  == "!" || cp != string::npos ) {
805        out << "!   " << lo_line   <<endl;                 // comment also in next line
806      } else {
807        out << "                    " << lo_line   <<endl;
808      }
809    }
810  }
811
812  out << " " <<endl;
813
814  return;
815}
816
817void fortran_file::copy_to_MZ_KPP (fortran_file & ka) {
818
819  vector<program_line>::iterator     ip;
820
821  for (ip=pline.begin(); ip != pline.end(); ip++) {
822//  Do not copy lines marked for delete
823    if(ip->get_token(0) != "!DELETE") {
824      ka.add_line( ip->get_line() );
825    }
826  }
827
828  return;
829}
830void  fortran_file::global_substitute(string &line, string old_s, string new_s) {
831   int         pos;
832
833   int start = line.size()-1;
834
835   while (1) {
836     pos = line.rfind (old_s, start);       // look for string
837
838     if (pos == string::npos) {
839       break;
840     }
841
842     line.replace(pos,old_s.size(),new_s);
843
844     start = pos-1;
845   }
846
847   return;
848}
849
850void  fortran_file::global_subtolower(string &line) {
851
852   int start = line.size()-1;
853   char c;
854
855    int i = 0;
856    while (line[i])
857    {
858      c = line[i];
859      line[i] = tolower(c);
860      i++;
861    }
862   return;
863}
Note: See TracBrowser for help on using the repository browser.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |