source: palm/trunk/UTIL/chemistry/gasphase_preproc/kpp4palm/src/create_kpp_module.C @ 3298

Last change on this file since 3298 was 3298, checked in by kanani, 3 years ago

Merge chemistry branch at r3297 to trunk

File size: 22.0 KB
Line 
1
2// ############################################################################
3//
4//     create_kpp_module
5//
6//     create scalar code from .f90 sources created by KPP
7//
8//     COPYRIGHT Klaus Ketelsen and MPI-CH   April 2007
9//
10// ############################################################################
11//
12//Current revisions:
13//------------------
14/ 
15/ 
16//Former revisions:
17//-----------------
18//$Id: create_kpp_module.C 2470 2017-09-14 13:56:42Z forkel $
19// forkel 25.09.2018:  added  automatic line with meechanism name (read mech_list)
20// forkel 20.09.2018:  added  vl_glo = size(tempi,1)
21// ketelsen 18.09.2018: Removed creation of fill_ Subroutine and creation of calls thereof
22//
23// forkel 12.09.2018: Fix in order not to loose the values of qvap and fakt
24//
25// forkel 03.09.2018: Bug fix: moved kppi.add_line("    CALL initialize after fakt = fakti(is)
26// forkel June 2018: added qvap and fakt, re-established original uppercase/lowercase
27//                    Deleted definition of qvap,fakt in create_kpp_integrate again
28//
29// ketelsen July 2018: Changes for vector mode (edit_WAXPY, edit_FunTemplate, edit_JacTemplate,
30//                            some cleanup of comments, various changes in create_kpp_integrate)
31//
32// forkel June 2018: Added qvap and fakt, re-established original uppercase/lowercase
33//
34//
35/ 2017-09-14 13:56:42Z forkel $
36// Removed preprocessor directive __chem again
37//
38// 2017-09-14 13:56:42Z forkel $
39//
40//
41//added phot
42//change of some output to lowercase with uppercase Fortran
43//
44// Nov 2016: Intial version of KP4 adapted to PALM (Klaus Ketelsen)
45//
46
47#include <stdio.h>
48//  mz_rs_20090111+
49// stdlib is necessary to define getenv:
50#include <stdlib.h>
51//  mz_rs_20090111-
52
53#include "create_kpp_module.h"
54#include "utils.h"
55
56void create_kpp_module::do_work (string s) {
57   vector<fortran_file>::iterator  it;
58   vector<string>::iterator        ic;
59   vector<Vvar>::iterator          iv;
60
61   expand_decomp                   exp_de;
62
63   prefix = s;
64   module_name = prefix;
65
66   cout << "Create " << module_name << " from kpp Fortran sources" <<endl;
67   cout << "Vector mode " << kpp_switches.is_vector() <<endl;
68   cout << "De_indexing " << kpp_switches.de_indexing() <<endl;
69
70   create_fortran_files_and_read();
71
72// Generate first module lines
73
74     string first_line="MODULE " + module_name;
75   mz_kpp.add_line(first_line);
76   mz_kpp.add_line(" ");
77
78//    string e5_line = first_line +"_e5";
79//    e5_kpp.add_line(e5_line);
80//    e5_line = "  USE             " + module_name;
81//    e5_kpp.add_line(e5_line);
82//    e5_kpp.add_line(" ");
83
84// edit include files
85
86   for(it=kpp_includes.begin();it!=kpp_includes.end();it++) {
87     it->edit_inc(header_variables);
88
89//   Create variable Species list and vector variable list
90
91     if(it->get_name() == module_name + "_Parameters") {
92       it->create_species_list(species_list);
93     }
94     if(it->get_name() == module_name + "_Global") {
95       it->vector_variable_list(Vvar_list);
96     }
97   }
98
99// Prepare expansion of decomposition subroutine
100
101   if(kpp_switches.de_indexing () > 0 ) {
102     exp_de.create_sparse_info (kpp_includes, module_name);
103   }
104
105// edit FORTRAN files
106
107   for(it=kpp_files.begin();it!=kpp_files.end();it++) {
108     it->edit_fortran ();
109   }
110
111// Generate a list of single subroutines from kpp-files
112// kpp files are modules containing several subroutines
113
114   copy_files_to_subroutines ();
115
116// All header_variables to include list
117
118   kpp_includes.push_back(header_variables);
119
120// Create decomposition subroutine
121   if(kpp_switches.de_indexing () > 0 ) {
122     exp_de.create_routine (kpp_subroutines);
123   }
124
125   if(kpp_switches.is_vector()) {
126
127   cout << "##### Hier kpp_switches.is_vector          " <<endl;
128//   Change header section
129     for(it=kpp_includes.begin();it!=kpp_includes.end();it++) {
130       it->edit_inc_vec(global_variable_list);
131     }
132
133//   Change global variables to vector
134     
135     for(it=kpp_subroutines.begin();it!=kpp_subroutines.end();it++) {
136       it->global_variables2vector (global_variable_list);
137     }
138
139//   Edit individual subroutines
140
141     for(it=kpp_subroutines.begin();it!=kpp_subroutines.end();it++) {
142       if(it->get_name() == "KppDecomp") {
143         it->edit_KppDecomp();
144       }
145       if(it->get_name() == "KppSolve") {
146         it->edit_KppSolve();
147       }
148       if(it->get_name() == "Jac_SP" ) {
149         it->edit_Jac_SP();
150       }
151       if(it->get_name() == "Fun" ) {
152         it->edit_Fun();
153       }
154       if(it->get_name() == "WAXPY" ) {
155         it->edit_WAXPY();
156       }
157       if(it->get_name() == "FunTemplate" ) {
158         it->edit_FunTemplate();
159       }
160       if(it->get_name() == "JacTemplate" ) {
161         it->edit_JacTemplate();
162       }
163     }
164// cout << "## after Edit individual subroutines    " <<endl;
165
166   }
167
168// Update_RCONST has to be changed also in scalar mode
169
170   for(it=kpp_subroutines.begin();it!=kpp_subroutines.end();it++) {
171     if(it->get_name() == "Update_RCONST") {
172       it->edit_Update_RCONST(Vvar_list);
173     }
174
175     if(it->get_name() == "Initialize") {
176       it->edit_Initialize(Vvar_list);
177     }
178
179   }
180
181// Add Solver template to subroutine list
182   if(kpp_switches.is_vector()) {
183     add_solver_to_subroutine_list ();
184   }
185
186// The module header will be taken from ../templates/module_header.
187// Please edit if header has to be changed.
188
189   generate_module_header();
190
191// Create kpp_integrate subroutine (chem_gasphase_integrate) for skalar and vector mode
192
193   create_kpp_integrate();
194// Copy include files
195
196   for(it=kpp_includes.begin();it!=kpp_includes.end();it++) {
197     it->copy_to_MZ_KPP(mz_kpp);
198   }
199
200   mz_kpp.add_line(" ");
201   mz_kpp.add_line("! Interface Block ");
202   mz_kpp.add_line(" ");
203   for(it=kpp_subroutines.begin();it!=kpp_subroutines.end();it++) {
204     string          buf;
205
206     string prefix = "  ";
207     for(ic=interface_ignore.begin();ic!=interface_ignore.end();ic++) {
208       if(it->get_name() == *ic) {
209         prefix = "!interface not working  ";
210         break;
211       }
212     }
213
214     buf = prefix + "interface            " + it->get_name() ;
215     mz_kpp.add_line(buf);
216     buf = prefix + "  module procedure   " + it->get_name();
217     mz_kpp.add_line(buf);
218     buf = prefix + "end interface        " + it->get_name();
219     mz_kpp.add_line(buf);
220     mz_kpp.add_line(" ");
221   }
222
223   mz_kpp.add_line(" ");
224
225
226// Copy FORTRAN subroutines to mz_kpp
227
228   mz_kpp.add_line(" CONTAINS");
229   
230   for(it=kpp_subroutines.begin();it!=kpp_subroutines.end();it++) {
231     mz_kpp.add_line(" ");
232     it->copy_to_MZ_KPP(mz_kpp);
233   }
234
235// Finish module
236
237   string last_line="end module " + module_name;
238   mz_kpp.add_line("");
239   mz_kpp.add_line(last_line);
240
241// Write the complete module to file: mz_kpp.f
242
243   write_module_file();
244
245   return;
246}
247
248void create_kpp_module::create_fortran_files_and_read() {
249
250   string                          name;
251   ifstream                        in,in_c,in_b,in_i;
252   fortran_file                    f_file;
253   vector<fortran_file>::iterator  it;
254
255// Open file with list of FORTRAN routines
256
257   in.open("file_list");
258   if( !in ) {
259      cout << "cannot open " << endl; my_abort("file_list");
260   }
261   
262// Create kpp_fortran routines
263   while ( 1 ) {
264     in >> name;
265     if( in.eof() ) break;
266     if( in.bad() ) my_abort("ERROR_READ_1");
267     f_file.set_name(name);
268     kpp_files.push_back(f_file);
269   }
270   in.close();
271
272// Read FORTRAN code
273
274   for(it=kpp_files.begin();it!=kpp_files.end();it++) {
275     it->read();
276   }
277
278// Open file with list of include files
279
280   in_c.open("include_list");
281   if( !in_c ) {
282      cout << "cannot open " << endl; my_abort("include_list");
283   }
284
285// Create kpp_includes vector
286   while ( 1 ) {
287     in_c >> name;
288     if( in_c.eof() ) break;
289     if( in_c.bad() ) my_abort("ERROR_READ_3");
290     f_file.set_name(name);
291     kpp_includes.push_back(f_file);
292   }
293   in_c.close();
294
295// Read include files
296
297   for(it=kpp_includes.begin();it!=kpp_includes.end();it++) {
298     it->read();
299   }
300
301// Read Ignore list
302
303   in_i.open("interface_ignore_list");
304   if( !in_i ) {
305      cout << "cannot open " << endl; my_abort("include_list");
306   }
307
308// Create kpp_includes vector
309   while ( 1 ) {
310     in_i >> name;
311     if( in_i.eof() ) break;
312     if( in_i.bad() ) my_abort("ERROR_READ_4");
313     interface_ignore.push_back(name);
314   }
315   in_c.close();
316
317}
318
319void create_kpp_module::copy_files_to_subroutines () {
320   string                          name;
321   ifstream                        in;
322   fortran_file                    s_file;
323   vector<fortran_file>::iterator  it;
324
325// Open file with list of FORTRAN routines
326
327   in.open("subroutine_list");
328   if( !in ) {
329      cout << "cannot open " << endl; my_abort("subroutine_list");
330   }
331
332// Create vector kpp_subroutines
333
334   while ( 1 ) {
335     in >> name;
336     if( in.eof() ) break;
337     if( in.bad() ) my_abort("ERROR_READ_S1");
338     s_file.set_name(name);
339     kpp_subroutines.push_back(s_file);
340   }
341   in.close();
342
343   header_variables.add_line(" ");
344   header_variables.add_line("!  variable definations from  individual module headers ");
345   header_variables.add_line(" ");
346
347//  Loop over all FORTRAN Files
348
349   for(it=kpp_files.begin();it!=kpp_files.end();it++) {
350     it->copy_to_subroutine_vector(kpp_subroutines, header_variables);
351   }
352}
353
354void create_kpp_module::add_solver_to_subroutine_list () {
355   fortran_file                    s_file;
356
357   string solver_name = getenv("KPP_SOLVER");
358   cout << "KPP_SOLVER " <<solver_name <<endl;
359   
360   s_file.set_name(solver_name);
361   s_file.read();
362   kpp_subroutines.push_back(s_file);
363
364   return;
365}
366
367void create_kpp_module::generate_module_header() {
368
369   string                          buf;
370   ifstream                        in;
371   ifstream                        in_e5;
372   program_line                    line;
373   vector<fortran_file>::iterator  it;
374   char                            distr[2];
375   string                          diline;
376
377// Read mechanism from mech_list
378
379   in.open("mech_list");
380   if( !in ) {
381      cout << "cannot open " << endl; my_abort("mech_list");
382   }
383
384   while ( 1 ) {
385     getline (in, buf);
386     if( in.eof() ) break;
387     if( in.bad() ) my_abort("ERROR_READ_4");
388     line.set_line(buf);
389     mz_kpp.add_line(line);
390   }
391   in.close();
392
393
394// Read Modul Header from file $MZ_KPP_HOME/templates/module_header
395
396   in.open("module_header");
397   if( !in ) {
398      cout << "cannot open " << endl; my_abort("module_header");
399   }
400
401   while ( 1 ) {
402     getline (in, buf);
403     if( in.eof() ) break;
404     if( in.bad() ) my_abort("ERROR_READ_4");
405     line.set_line(buf);
406     mz_kpp.add_line(line); 
407   }
408   mz_kpp.add_line("                                                                 "); 
409   mz_kpp.add_line("! Variables used for vector mode                                 "); 
410   mz_kpp.add_line("                                                                 "); 
411   if(kpp_switches.is_vector()) {
412       mz_kpp.add_line("  logical,parameter          :: L_VECTOR = .TRUE.             ");
413   } else {
414       mz_kpp.add_line("  logical,parameter          :: L_VECTOR = .FALSE.            ");
415   }
416//  mz_pj_20070531+
417   sprintf(distr,"%i",kpp_switches.de_indexing());
418   diline = distr ;
419   mz_kpp.add_line("  integer,parameter          :: I_LU_DI = " + diline );
420//  mz_pj_20070531-
421
422   mz_kpp.add_line("  integer,parameter          :: VL_DIM = " 
423                 + kpp_switches.get_vector_length() ); 
424   mz_kpp.add_line("  integer                     :: vl                              "); 
425   mz_kpp.add_line("                                                                 "); 
426   mz_kpp.add_line("  integer                     :: VL_glo                          "); 
427   mz_kpp.add_line("  integer                     :: is,ie                           "); 
428   mz_kpp.add_line("                                                                 "); 
429   mz_kpp.add_line("                                                                 "); 
430   mz_kpp.add_line("  integer, dimension(VL_dim)   :: Kacc,Krej                       "); 
431   mz_kpp.add_line("  integer, dimension(VL_dim)   :: IERRV                           "); 
432   mz_kpp.add_line("  logical                     :: data_loaded = .false.             "); 
433
434   in.close();
435
436   return;
437}
438
439void create_kpp_module::write_module_file() {
440   ofstream                    out;
441   ofstream                    out_e5;
442
443   string out_file  = "kk_kpp.f90";
444   out.open(out_file.c_str(), ios::out);
445   if( !out ) {
446      cout << "cannot open " << endl; my_abort(out_file);
447   }
448
449   mz_kpp.write_file (out);
450
451   out.close();
452   
453
454   return;
455}
456
457void create_kpp_module::create_kpp_integrate() {
458   fortran_file          kppi;
459   vector<Vvar>::iterator               iv;
460   string                               line;
461
462   kppi.set_name("chem_gasphase_integrate");
463
464   kppi.add_line("SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, icntrl_i, rcntrl_i )  ");
465   kppi.add_line("                                                                    ");
466   kppi.add_line("  IMPLICIT NONE                                                     ");
467   kppi.add_line("                                                                    ");
468
469   kppi.add_line("  REAL(dp), INTENT(IN)                   :: time_step_len           ");
470   kppi.add_line("  REAL(dp),  DIMENSION(:,:),  INTENT(INOUT) :: conc                    ");
471   kppi.add_line("  REAL(dp),  DIMENSION(:,:),  INTENT(IN)    :: photo                   ");
472   kppi.add_line("  REAL(dp),  DIMENSION(:),  INTENT(IN)      :: tempi                   ");
473   kppi.add_line("  REAL(dp),  DIMENSION(:),  INTENT(IN)      :: qvapi                   ");
474   kppi.add_line("  REAL(dp),  DIMENSION(:),  INTENT(IN)      :: fakti                   ");
475   kppi.add_line("  INTEGER,  INTENT(OUT), OPTIONAL        :: ierrf(:)                ");
476   kppi.add_line("  INTEGER,  INTENT(OUT), OPTIONAL        :: xNacc(:)                ");
477   kppi.add_line("  INTEGER,  INTENT(OUT), OPTIONAL        :: xNrej(:)                ");
478   kppi.add_line("  INTEGER,  INTENT(INOUT), OPTIONAL      :: istatus(:)              ");
479   kppi.add_line("  INTEGER,  INTENT(IN), OPTIONAL         :: PE                      ");
480   kppi.add_line("  LOGICAL,  INTENT(IN), OPTIONAL         :: l_debug                 ");
481   kppi.add_line("  INTEGER,  DIMENSION(nkppctrl),INTENT(IN), OPTIONAL  :: icntrl_i         ");
482   kppi.add_line("  REAL(dp), DIMENSION(nkppctrl),INTENT(IN), OPTIONAL  :: rcntrl_i         ");
483   kppi.add_line("                                                                    ");
484   kppi.add_line("  INTEGER                                 :: k   ! loop variable     ");
485   kppi.add_line("  REAL(dp)                                :: dt                      ");
486   kppi.add_line("  integer, dimension(20)                 :: istatus_u               ");
487   kppi.add_line("  integer                                :: ierr_u                  ");
488   kppi.add_line("  integer                                :: istatf                  ");
489   kppi.add_line("  integer                                :: vl_dim_lo               ");
490   kppi.add_line("                                                                    ");
491   kppi.add_line("                                                                    ");
492   kppi.add_line("  if (present (istatus) )   istatus = 0                             ");
493   kppi.add_line("  if (present (icntrl_i) )  icntrl  = icntrl_i                      ");
494   kppi.add_line("  if (present (rcntrl_i) )  rcntrl  = rcntrl_i                      ");
495   kppi.add_line("                                                                    ");
496   kppi.add_line("  vl_glo = size(tempi,1)                                            ");
497   kppi.add_line("                                                                    ");
498   kppi.add_line("  vl_dim_lo = VL_DIM                                                ");
499   kppi.add_line("  DO k=1,VL_glo,vl_dim_lo                                           ");
500   kppi.add_line("    is = k                                                          ");
501   kppi.add_line("    ie = min(k+vl_dim_lo-1,VL_glo)                                  ");
502   kppi.add_line("    vl = ie-is+1                                                    ");
503
504   kppi.add_line("                                                                    ");
505   if(kpp_switches.is_vector()) {
506     kppi.add_line("    C(1:vl,:) = Conc(is:ie,:)                                     ");
507   } else {
508     kppi.add_line("    C(:) = Conc(is,:)                                             ");
509   }
510
511   kppi.add_line("                                                                    ");
512   if(kpp_switches.is_vector()) {
513     kppi.add_line("    temp(1:vl) = tempi(is:ie)                                     ");
514   } else {
515     kppi.add_line("    temp = tempi(is)                                              ");
516   }
517   kppi.add_line("                                                                    ");
518   if(kpp_switches.is_vector()) {
519     kppi.add_line("    qvap(1:vl) = qvapi(is:ie)                                     ");
520   } else {
521     kppi.add_line("    qvap = qvapi(is)                                              ");
522   }
523   kppi.add_line("                                                                    ");
524   if(kpp_switches.is_vector()) {
525     kppi.add_line("    fakt(1:vl) = fakti(is:ie)                                     ");
526   } else {
527     kppi.add_line("    fakt = fakti(is)                                              ");
528   }
529
530   kppi.add_line("                                                                    ");
531   kppi.add_line("    CALL initialize                                                 ");
532
533   kppi.add_line("                                                                    ");
534   if(kpp_switches.is_vector()) {
535     kppi.add_line("    phot(1:vl,:) = photo(is:ie,:)                                     ");
536   } else {
537     kppi.add_line("    phot(:) = photo(is,:)                                             ");
538   }
539   kppi.add_line("                                                                    ");
540   kppi.add_line("    CALL update_rconst                                              ");
541   kppi.add_line("                                                                    ");
542   kppi.add_line("    dt = time_step_len                                              ");
543   kppi.add_line("                                                                    ");
544   kppi.add_line("    ! integrate from t=0 to t=dt                                    ");
545   kppi.add_line("    CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)");
546   kppi.add_line("                                                                    ");
547   kppi.add_line("                                                                    ");
548   if(kpp_switches.is_vector()) {
549     kppi.add_line("    Conc(is:ie,:) = C(1:VL,:)                                     ");
550   } else {
551     kppi.add_line("   IF (PRESENT(l_debug) .AND. PRESENT(PE)) THEN                       ");
552     kppi.add_line("      IF (l_debug) CALL error_output(Conc(is,:),ierr_u, PE)           ");
553     kppi.add_line("   ENDIF                                                              ");
554     kppi.add_line("                                                                      ");
555     kppi.add_line("    Conc(is,:) = C(:)                                                 ");
556   }
557
558   kppi.add_line("                                                                    ");
559   kppi.add_line("    ! Return Diagnostic Information                                 ");
560   kppi.add_line("                                                                    ");
561   if(kpp_switches.is_vector()) {
562     kppi.add_line("    if(Present(ierrf))    ierrf(is:ie) = IERRV(1:VL)              ");
563     kppi.add_line("    if(Present(xNacc))    xNacc(is:ie) = Kacc(1:VL)               ");
564     kppi.add_line("    if(Present(xNrej))    xNrej(is:ie) = Krej(1:VL)               ");
565   } else {
566     kppi.add_line("    if(Present(ierrf))    ierrf(is) = IERR_U                      ");
567     kppi.add_line("    if(Present(xNacc))    xNacc(is) = istatus_u(4)                ");
568     kppi.add_line("    if(Present(xNrej))    xNrej(is) = istatus_u(5)                ");
569   }
570   kppi.add_line("                                                                    ");
571   kppi.add_line("    if (present (istatus) )  then                                   ");
572   if(kpp_switches.is_vector()) {
573     kppi.add_line("      istatus(4) =   istatus(4) + sum(Kacc(1:VL))                  ");
574     kppi.add_line("      istatus(5) =   istatus(5) + sum(Krej(1:VL))                  ");
575     kppi.add_line("      istatus(3) =   istatus(4) + istatus(5)                       ");
576     kppi.add_line("      istatus(6) =   istatus(6) + istatus_u(6)                     ");
577     kppi.add_line("      istatus(7) =   istatus(7) + istatus_u(7)                     ");
578   } else {
579     kppi.add_line("      istatus(1:8) = istatus(1:8) + istatus_u(1:8)                 ");
580   }
581   kppi.add_line("    end if                                                          ");
582   kppi.add_line("                                                                    ");
583   kppi.add_line("  END DO                                                            ");
584   kppi.add_line(" ");
585
586   kppi.add_line("                                                                    ");
587   kppi.add_line("! Deallocate input arrays                                           ");
588   kppi.add_line("                                                                    ");
589   for(iv=Vvar_list.begin();iv!=Vvar_list.end();iv++) {
590//     kppi.add_line("  if (allocated("+ iv->name +"))   deallocate("+ iv->name +" )    ");
591   }
592
593   kppi.add_line("                                                                    ");
594   kppi.add_line("  data_loaded = .false.                                             ");
595   kppi.add_line("                                                                    ");
596   kppi.add_line("  return                                                            ");
597   kppi.add_line("END SUBROUTINE chem_gasphase_integrate                                        ");
598
599//   e5_subroutines.push_back(kppi);
600   kpp_subroutines.push_back(kppi);
601
602   return;
603}
604
Note: See TracBrowser for help on using the repository browser.