source: trunk/AGRIF/LIB/SubLoopCreation.c @ 396

Last change on this file since 396 was 396, checked in by opalod, 15 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 24.4 KB
Line 
1/******************************************************************************/
2/*                                                                            */
3/*     CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran)       */
4/*                                                                            */
5/*     Copyright (C) 2005 Laurent Debreu (Laurent.Debreu@imag.fr)             */
6/*                        Cyril Mazauric (Cyril.Mazauric@imag.fr)             */
7/*                                                                            */
8/*     This program is free software; you can redistribute it and/or modify   */
9/*    it                                                                      */
10/*                                                                            */
11/*    This program is distributed in the hope that it will be useful,         */
12/*     but WITHOUT ANY WARRANTY; without even the implied warranty of         */
13/*     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the          */
14/*    GNU General Public License for more details.                            */
15/*                                                                            */
16/******************************************************************************/
17#include <stdio.h>
18#include <stdlib.h>
19#include <string.h>
20#include "decl.h"
21
22
23/******************************************************************************/
24/*     preparation and write of the argument list of a subroutine             */
25/******************************************************************************/
26 
27 
28/******************************************************************************/
29/*                        OPTI_0_writeheadnewsubforsub                        */
30/******************************************************************************/
31/* Firstpass 0                                                                */
32/* We should write the head of the subroutine sub_loop_<subroutinename>       */
33/******************************************************************************/
34/*                                                                            */
35/******************************************************************************/
36void OPTI_0_writeheadnewsubforsub()
37{
38   int out;
39   listusemodule *newmodule;
40   
41   if ( firstpass == 0 && OPTI_0_IsTabvarsUseInArgument() == 1 ) 
42   {
43
44      /* we should add the use agrif_util if it is necessary                  */
45      newmodule = listofmodulebysubroutine;
46      out = 0 ;
47      if ( adduseagrifutil != 1 && inmodulemeet == 0 )
48      {
49         while ( newmodule && out == 0 )
50         {
51             if ( !strcasecmp(newmodule->cursubroutine,subroutinename) ||
52                  !strcasecmp(newmodule->cursubroutine," ")
53                 )
54             {
55                if ( !strcasecmp(newmodule->charusemodule,"Agrif_Util") ) 
56                                                                        out = 1;
57             }
58             newmodule = newmodule ->suiv; 
59         }
60         if ( out == 0 ) tofich(fortranout,
61                             "\n      USE Agrif_Types, ONLY : Agrif_tabvars",1);
62      }
63      /* we should modify the name of the variable in the                     */
64      /* listvarindoloop which has been declared by the way of the            */
65      /* USE fortran  function : USE MOD, U => V                              */
66      ModifyThelistvarindoloop();
67      /* And write the head of the new subroutine                             */
68      WriteHeadofSubroutineLoop(); 
69      if ( OPTI_0_IsAllocateInThisSubroutine() == 1 && inmodulemeet == 0 )
70      {
71         tofich(fortranout,"\n      USE Agrif_Types, ONLY : Agrif_tabvars",1); 
72      }
73      else if ( out == 1 && fortran77 == 1 ) tofich(fortranout,
74                                                    "\n      USE Agrif_Util",1);
75      WriteUsemoduleDeclaration();
76      WriteIncludeDeclaration();
77      if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
78                                                       "      IMPLICIT NONE\n");
79      /* We should write once the declaration of tables (extract              */
80      /*    from pointer) in the new subroutine                               */
81      tmpdeclaration_everdone = 1;
82      if ( todebug == 1 ) fprintf(fortranout,"!!! 111111111111111 \n");
83      if ( fortran77 == 1 ) writesub_loopdeclaration
84                                                     (parameterlist,fortranout);
85      if ( todebug == 1 ) fprintf(fortranout,"!!! 222222222222222 \n");
86      writesub_loopdeclaration(listvarindoloop,fortranout);
87      if ( todebug == 1 ) fprintf(fortranout,"!!! 333333333333333 \n");
88      if ( fortran77 == 1 ) writesub_loopdeclaration
89                                              (varofsubroutineliste,fortranout);
90      if ( todebug == 1 ) fprintf(fortranout,"!!! 444444444444444 \n");
91      if ( fortran77 == 1 ) writesub_loopdeclaration
92                                                     (varsubroutine,fortranout);
93      if ( todebug == 1 ) fprintf(fortranout,"!!! 555555555555555 \n");
94      /* now we should write the function declaration                         */
95      /*    case if it is the                                                 */
96      writedeclaration (functionlistvar, fortranout,varofsubroutineliste);
97      if ( todebug == 1 ) fprintf(fortranout,"!!! 666666666666666 \n");
98   }
99   else if ( firstpass == 0 )
100   {
101      WriteUsemoduleDeclaration();
102      WriteIncludeDeclaration();
103   }
104   
105}
106
107
108/******************************************************************************/
109/*                        OPTI_0_writeheadnewsubforfunc                       */
110/******************************************************************************/
111/* Firstpass 0                                                                */
112/* We should write the head of the subroutine sub_loop_<subroutinename>       */
113/******************************************************************************/
114/*                                                                            */
115/******************************************************************************/
116void OPTI_0_writeheadnewsubforfunc()
117{
118   int out;
119   listusemodule *newmodule;
120
121   if ( firstpass == 0 && OPTI_0_IsTabvarsUseInArgument() == 1 )
122   {
123      /* we should add the use agrif_util if it is necessary                  */
124      newmodule = listofmodulebysubroutine;
125      out = 0 ;
126      if ( adduseagrifutil != 1 && inmodulemeet == 0 )
127      {
128         while ( newmodule && out == 0 )
129         {
130             if ( !strcasecmp(newmodule->cursubroutine,subroutinename) ||
131                  !strcasecmp(newmodule->cursubroutine," ")
132                 )
133             {
134                if ( !strcasecmp(newmodule->charusemodule,"Agrif_Util") ) 
135                                                                        out = 1;
136             }
137             newmodule = newmodule ->suiv; 
138         }
139         if ( out == 0 ) tofich(fortranout,
140                             "\n      USE Agrif_Types, ONLY : Agrif_tabvars",1);
141      }
142      WriteHeadofSubroutineLoop();   
143      if ( OPTI_0_IsAllocateInThisSubroutine() == 1 && inmodulemeet == 0 )
144           tofich(fortranout,"\n      USE Agrif_Types, ONLY : Agrif_tabvars",1);
145      WriteUsemoduleDeclaration();
146      WriteIncludeDeclaration();
147      if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
148                                                       "      IMPLICIT NONE\n");
149      /* We should write once the declaration of tables (extract              */
150      /*    from pointer) in the new subroutine                               */
151      tmpdeclaration_everdone = 1;
152      if ( fortran77 == 1 ) writesub_loopdeclaration
153                                                     (parameterlist,fortranout);
154      writesub_loopdeclaration(listvarindoloop,fortranout);
155      if ( fortran77 == 1 ) writesub_loopdeclaration
156                                                     (varsubroutine,fortranout);
157      if ( fortran77 == 1 ) writesub_loopdeclaration
158                                              (varofsubroutineliste,fortranout);
159      /* now we should write the function declaration                         */
160      /*    case if it is the                                                 */
161      writedeclaration (functionlistvar, fortranout,varofsubroutineliste);
162   }
163   else if ( firstpass == 0 ) 
164   {
165      WriteUsemoduleDeclaration();
166      WriteIncludeDeclaration();
167   }
168}
169
170
171/******************************************************************************/
172/*                    OPTI_0_writesubroutinedeclaration                       */
173/******************************************************************************/
174/* Firstpass 0                                                                */
175/* We should write the declaration of the subroutine in order to              */
176/* create the new sub_loop subroutine                                         */
177/******************************************************************************/
178/*                                                                            */
179/******************************************************************************/
180void OPTI_0_writesubroutinedeclaration(listvar *listtomodify)
181{
182   if ( VariableIsParameter == 0 && SaveDeclare == 0)
183   {
184      if (firstpass == 0 && OPTI_0_IsTabvarsUseInArgument() == 1 )
185      {
186         /* We should write this declaration into the original                */
187         /*    subroutine too                                                 */
188        if ( fortran77 == 1                 && 
189             paramdeclaration_everdone == 0 && 
190             varofsubroutineliste
191           )
192        {
193           paramdeclaration_everdone = 1;
194           writedeclarationsubroutinedeclaration
195                             (parameterlist,oldfortranout,varofsubroutineliste);
196        }
197        writedeclaration (listtomodify, oldfortranout,varofsubroutineliste);
198      }
199   }
200}
201
202/******************************************************************************/
203/*                    WriteVariablelist_subloop                               */
204/******************************************************************************/
205/* This subroutine is used to write the list of the variable which            */
206/* should be called by the sub_loop_<name> subroutine                         */
207/* The first part is composed by the list of the local variables              */
208/******************************************************************************/
209/*                                                                            */
210/*    varofsubroutineliste              a,b,c,  &                             */
211/*                                      d,e,f,  &                             */
212/*     a,b,c,d,e,f,g,h     ========>    g,h                                   */
213/*                                                                            */
214/******************************************************************************/
215void WriteVariablelist_subloop(FILE *outputfile)
216{
217   listvar *parcours;   
218   char ligne[LONGNOM];
219   int compteur;
220   
221   parcours = varofsubroutineliste;
222   didvariableadded = 0;
223   compteur = 0 ;
224   
225   while ( parcours )   
226   {
227      /* if the readed variable is a variable of the subroutine               */
228      /*    subroutinename we should write the name of this variable          */
229      /*    in the output file                                                */
230      if ( !strcasecmp(parcours->var->modulename,subroutinename) )
231      {     
232         if ( didvariableadded == 0 )
233         {
234            strcpy(ligne,"");
235         }
236         else
237         {
238            if ( compteur == 0 ) strcpy(ligne,"");
239            strcat(ligne,",");
240         }
241         strcat(ligne,parcours->var->nomvar);
242         didvariableadded = 1;
243         compteur = compteur + 1;
244         if ( compteur == 3 ) 
245         {
246            if ( fortran77 == 0 ) strcat(ligne," &");
247            if ( fortran77 == 0 ) fprintf(outputfile,"\n      %s",ligne);
248            else fprintf(outputfile,"\n     & %s",ligne);
249            compteur = 0;
250         }
251      }
252      parcours = parcours -> suiv;   
253   }
254   if ( compteur != 3 && compteur != 0 ) 
255   {
256      if ( fortran77 == 0 ) fprintf(outputfile,"\n      %s &",ligne);
257      else fprintf(outputfile,"\n     & %s ",ligne);
258   }
259}
260
261
262/******************************************************************************/
263/*                     WriteVariablelist_subloop_Call                         */
264/******************************************************************************/
265/* This subroutine is used to write the list of the variable which            */
266/* should be called by the sub_loop_<name> subroutine into the called         */
267/* The second part is composed by the list of the global table                */
268/******************************************************************************/
269/*                                                                            */
270/*      listvarindoloop        SubloopScalar = 0 | SubloopScalar = 1          */
271/*                                a,b,c,  &      |  a,b(1,1),c,      &        */
272/*     a,b,c,d,e,f,g,h  =====>    d,e,f,  &      |  d(1),e(1,1,1),f, &        */
273/*                                g,h            |  g,h(1,1)                  */
274/*                                                                            */
275/******************************************************************************/
276void  WriteVariablelist_subloop_Call(FILE *outputfile)
277{
278   listvar *parcours;   
279   char ligne[LONGNOM*100];
280   char ligne2[10];
281   int i;
282   
283   parcours = listvarindoloop;
284   while ( parcours )   
285   {
286      /* if the readed variable is a variable of the subroutine               */
287      /*    subroutinename we should write the name of this variable          */
288      /*    in the output file                                                */
289      if ( !strcasecmp(parcours->var->modulename,subroutinename) )
290      {
291         if ( didvariableadded == 0 )
292         {
293            strcpy(ligne,"");
294         }
295         else
296         {
297            strcpy(ligne,"");
298            strcat(ligne,",");
299         }
300         strcat(ligne,vargridcurgridtabvars(parcours->var,0));
301         /* if it is asked in the call of the conv we should give             */
302         /* scalar in argument, so we should put (1,1,1) after the            */
303         /* the name of the variable                                          */
304         if (  SubloopScalar != 0 && 
305               (OPTI_0_IsVarAllocatable(parcours->var->nomvar) == 0 && 
306          parcours->var->pointerdeclare == 0 ) &&
307               parcours->var->nbdim != 0 )
308         {
309             i = 1;
310             while ( i <=  parcours->var->nbdim )
311             {
312                if ( i == 1 ) strcat(ligne,"( ");
313                if ( SubloopScalar == 2 )
314                {
315                   strcat(ligne,":");
316                   if ( i != parcours->var->nbdim ) strcat(ligne,",");
317                }
318                else
319                {
320                   strcat(ligne," lbound( ");
321                   strcat(ligne,vargridcurgridtabvars(parcours->var,0));
322                   strcat(ligne,",");
323                   strcpy(ligne2,"");
324                   sprintf(ligne2,"%d",i);
325                   strcat(ligne,ligne2);
326                   if ( i != parcours->var->nbdim ) strcat(ligne,"),");
327                }
328                if ( i == parcours->var->nbdim ) strcat(ligne,"))");
329                i++;
330             }
331         }
332         didvariableadded = 1;
333         if ( fortran77 == 0 ) strcat(ligne," &");
334         if ( fortran77 == 0 ) fprintf(outputfile,"\n");
335         else fprintf(outputfile,"\n     & ");
336         tofich(outputfile,ligne,0);
337      }
338      parcours = parcours -> suiv;   
339   }
340   /* Now we should replace the last ", &" by " &"                            */
341   if ( didvariableadded != 0 && fortran77 == 0 ) fseek(outputfile,-1,SEEK_CUR);
342   if ( didvariableadded == 0 ) fseek(outputfile,-2,SEEK_CUR);
343}
344
345
346/******************************************************************************/
347/*                       WriteVariablelist_subloop_Def                        */
348/******************************************************************************/
349/* This subroutine is used to write the list of the variable which            */
350/* should be called by the sub_loop_<name> subroutine into the def            */
351/* The second part is composed by the list of the global table                */
352/* <name>_tmp                                                                 */
353/******************************************************************************/
354/*                                                                            */
355/*       listvarindoloop                                                      */
356/*                                a-tmp,b-tmp,c_tmp, &                        */
357/*     a,b,c,d,e,f,g,h  =====>    d_tmp,e_tmp,f_tmp, &                        */
358/*                                g_tmp,h_tmp                                 */
359/*                                                                            */
360/******************************************************************************/
361void  WriteVariablelist_subloop_Def(FILE *outputfile)
362{
363   listvar *parcours;   
364   char ligne[LONGNOM];
365   int compteur;
366
367   parcours = listvarindoloop;
368   compteur = 0 ;
369   while ( parcours )   
370   {
371      /* if the readed variable is a variable of the subroutine               */
372      /*    subrotinename we should write the name of this variable           */
373      /*    in the output file                                                */
374      if ( !strcasecmp(parcours->var->modulename,subroutinename) )
375      {
376         if ( didvariableadded == 0 )
377         {
378            strcpy(ligne,"");
379         }
380         else
381         {
382            if ( compteur == 0 ) strcpy(ligne,"");
383            strcat(ligne,",");
384         }
385         strcat(ligne,parcours->var->nomvar);
386         compteur = compteur + 1;
387         didvariableadded = 1;
388         if ( compteur == 3 ) 
389         {
390            if ( fortran77 == 0 ) strcat(ligne," &");
391            if ( fortran77 == 0 ) fprintf(outputfile,"\n      %s",ligne);
392            else fprintf(outputfile,"\n     & %s",ligne);
393            compteur = 0;
394         }
395      }
396      parcours = parcours -> suiv;   
397   }   
398   if ( compteur != 3 && compteur != 0 )
399   {
400      if ( fortran77 == 0 ) fprintf(outputfile,"\n      %s &",ligne);
401      else fprintf(outputfile,"\n     & %s",ligne);
402   }
403
404   /* Now we should replace the last ", &" by " &"                            */
405   if ( didvariableadded != 0 && fortran77 == 0 ) fseek(outputfile,-1,SEEK_CUR);
406   if ( didvariableadded == 0 ) fseek(outputfile,-1,SEEK_CUR);
407}
408
409
410/******************************************************************************/
411/*                      WriteHeadofSubroutineLoop                             */
412/******************************************************************************/
413/* This subroutine is used to write the head of the subroutine                */
414/* Sub_Loop_<name>                                                            */
415/******************************************************************************/
416/*                 Sub_loop_subroutine.h                                      */
417/*                                                                            */
418/*                 subroutine Sub_Loop_subroutine ( &                         */
419/*                 a,b,c, &                                                   */
420/* SubLoopScalar   d,e(1,1),f(1,1,1), &                                       */
421/*                 g,h  &                                                     */
422/*                 )                                                          */
423/* adduseagrifutil USE Agrif_Util                                             */
424/******************************************************************************/
425void  WriteHeadofSubroutineLoop()
426{
427   char ligne[LONGNOM];
428   FILE * subloop;
429
430
431   tofich(fortranout,"\n",1);
432   /* Open this newfile                                                       */
433   sprintf(ligne,"Sub_Loop_%s.h",subroutinename);
434   subloop = associate(ligne);
435   /*                                                                         */
436   if ( fortran77 == 0 ) sprintf(ligne,"      subroutine Sub_Loop_%s( &"
437                                                               ,subroutinename);
438   else sprintf(ligne,"      subroutine Sub_Loop_%s( ",subroutinename);
439   fprintf(subloop,ligne);
440   /*                                                                         */
441   WriteVariablelist_subloop(subloop);
442   WriteVariablelist_subloop_Def(subloop);
443   /*                                                                         */
444   sprintf(ligne,")");
445   tofich(subloop,ligne,1);   
446   /* if USE agrif_Util should be add                                         */
447   if ( adduseagrifutil == 1 ) fprintf(subloop,"\n      USE Agrif_Util\n");
448   /*                                                                         */
449   oldfortranout = fortranout;
450   fortranout = subloop;
451}
452
453/******************************************************************************/
454/*                OPTI_0_closeandcallsubloopandincludeit                      */
455/******************************************************************************/
456/* Firstpass 0                                                                */
457/* We should close the sub_loop subroutine, call it and close the             */
458/* function (suborfun = 0)                                                    */
459/* subroutine (suborfun = 1)                                                  */
460/* end (suborfun = 2)                                                         */
461/* end program (suborfun = 3)                                                 */
462/* and include the sub_loop subroutine after                                  */
463/******************************************************************************/
464/*                                                                            */
465/******************************************************************************/
466void OPTI_0_closeandcallsubloopandincludeit(int suborfun, char endsub[LONGNOM],
467                                                          char optname[LONGNOM])
468{
469   char ligne[LONGNOM];
470
471   if ( firstpass == 0 ) 
472   {
473   if ( OPTI_0_IsTabvarsUseInArgument() == 1 )
474   {
475      /* We should remove the key word end subroutine                         */
476      RemoveWordCUR(fortranout,(long)(-strlen(optname)-strlen(endsub)-1),
477                                       strlen(optname)+strlen(endsub)+1);
478      /* We should close the loop subroutine                                  */
479      sprintf(ligne,"\n      end subroutine Sub_Loop_%s",subroutinename);
480      tofich(fortranout,ligne,1);
481      fclose(fortranout); 
482      fortranout = oldfortranout;
483      /* Now we add the call af the new subroutine                            */
484      if ( fortran77 == 0 ) sprintf(ligne,"\n      Call Sub_Loop_%s( &"
485                                                               ,subroutinename);
486      else sprintf(ligne,"\n      Call Sub_Loop_%s( ",subroutinename);
487      fprintf(fortranout,ligne);
488      /* Write the list of the local variables used in this new subroutine    */
489      WriteVariablelist_subloop(fortranout);
490      /* Write the list of the global tables used in this new subroutine      */
491      /*    in doloop                                                         */
492      WriteVariablelist_subloop_Call(fortranout); 
493      /* Close the parenthesis of the new subroutine called                   */
494      sprintf(ligne,")");
495      tofich(fortranout,ligne,1); 
496      /* We should close the original subroutine                              */
497      if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
498      {
499/*         fprintf(fortranout,"      CALL Agrif_Deallocation\n");*/
500      }
501      if ( suborfun == 3 ) sprintf(ligne,"\n      end program %s"
502                                                               ,subroutinename);
503      if ( suborfun == 2 ) sprintf(ligne,"\n      end");
504      if ( suborfun == 1 ) sprintf(ligne,"\n      end subroutine %s"
505                                                               ,subroutinename);
506      if ( suborfun == 0 ) sprintf(ligne,"\n      end function %s"
507                                                               ,subroutinename);
508      tofich(fortranout,ligne,1);
509      /* we should include the above file in the original code                */
510      sprintf(ligne,"\n#include \"Sub_Loop_%s.h\" \n",subroutinename);
511      tofich(fortranout,ligne,1);
512      }
513   }
514}
Note: See TracBrowser for help on using the repository browser.