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

Last change on this file since 3797 was 3797, checked in by forkel, 5 years ago

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