source: vendors/AGRIF/current/LIB/UtilFortran.c @ 1901

Last change on this file since 1901 was 1901, checked in by flavoni, 11 years ago

importing AGRIF vendor

File size: 25.6 KB
Line 
1/******************************************************************************/
2/*                                                                            */
3/*     CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran)       */
4/*                                                                            */
5/* Copyright or   or Copr. Laurent Debreu (Laurent.Debreu@imag.fr)            */
6/*                        Cyril Mazauric (Cyril_Mazauric@yahoo.fr)            */
7/* This software is governed by the CeCILL-C license under French law and     */
8/* abiding by the rules of distribution of free software.  You can  use,      */
9/* modify and/ or redistribute the software under the terms of the CeCILL-C   */
10/* license as circulated by CEA, CNRS and INRIA at the following URL          */
11/* "http://www.cecill.info".                                                  */
12/*                                                                            */
13/* As a counterpart to the access to the source code and  rights to copy,     */
14/* modify and redistribute granted by the license, users are provided only    */
15/* with a limited warranty  and the software's author,  the holder of the     */
16/* economic rights,  and the successive licensors  have only  limited         */
17/* liability.                                                                 */
18/*                                                                            */
19/* In this respect, the user's attention is drawn to the risks associated     */
20/* with loading,  using,  modifying and/or developing or reproducing the      */
21/* software by the user in light of its specific status of free software,     */
22/* that may mean  that it is complicated to manipulate,  and  that  also      */
23/* therefore means  that it is reserved for developers  and  experienced      */
24/* professionals having in-depth computer knowledge. Users are therefore      */
25/* encouraged to load and test the software's suitability as regards their    */
26/* requirements in conditions enabling the security of their systems and/or   */
27/* data to be ensured and,  more generally, to use and operate it in the      */
28/* same conditions as regards security.                                       */
29/*                                                                            */
30/* The fact that you are presently reading this means that you have had       */
31/* knowledge of the CeCILL-C license and that you accept its terms.           */
32/******************************************************************************/
33/* version 1.7                                                                */
34/******************************************************************************/
35#include <stdio.h>
36#include <stdlib.h>
37#include <string.h>
38#include "decl.h"
39
40/******************************************************************************/
41/*                            initdimprob                                     */
42/******************************************************************************/
43/* This subroutine is used to initialized grid dimension variable             */
44/******************************************************************************/
45/*                                                                            */
46/*                                                                            */
47/*                                                                            */
48/******************************************************************************/
49void initdimprob(int dimprobmod, char * nx, char * ny,char* nz)
50{
51  dimprob = dimprobmod;
52
53  strcpy(nbmaillesX,nx);
54  strcpy(nbmaillesY,ny);
55  strcpy(nbmaillesZ,nz);
56}
57
58/******************************************************************************/
59/*                      Variableshouldberemove                                */
60/******************************************************************************/
61/* Firstpass 0                                                                */
62/******************************************************************************/
63/*                                                                            */
64/*               Agrif_<toto>(variable) ====>     Agrif_<toto>(variable)      */
65/*                                                                            */
66/******************************************************************************/
67int Variableshouldberemove(char *nom)
68{
69
70   int remove;
71
72   remove = 0 ;
73
74   if ( remove == 0 && Agrif_in_Tok_NAME(nom) == 1 ) remove = 1 ;
75
76   return remove;
77}
78
79/******************************************************************************/
80/*                          variableisglobal                                  */
81/******************************************************************************/
82/* This subroutine is to know if a variable is global                         */
83/******************************************************************************/
84int variableisglobal(listvar *curvar, listvar *listin)
85{
86  int Globalite;
87  listvar *newvar;
88
89
90  Globalite = 0;
91  newvar = listin;
92  while ( newvar && Globalite == 0 )
93  {
94     if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) )
95     {
96        Globalite = 1;
97        /* Now we should give the definition of the variable in the           */
98        /* table List_UsedInSubroutine_Var                                    */
99        strcpy(curvar->var->v_typevar,newvar->var->v_typevar);
100        strcpy(curvar->var->v_dimchar,newvar->var->v_dimchar);
101        curvar->var->v_nbdim = newvar->var->v_nbdim;
102        curvar->var->v_dimensiongiven = newvar->var->v_dimensiongiven;
103        curvar->var->v_allocatable = newvar->var->v_allocatable;
104        curvar->var->v_pointerdeclare = newvar->var->v_pointerdeclare;
105        curvar->var->v_indicetabvars = newvar->var->v_indicetabvars;
106        strcpy(curvar->var->v_nameinttypename,newvar->var->v_nameinttypename);
107        strcpy(curvar->var->v_precision,newvar->var->v_precision);
108        strcpy(curvar->var->v_readedlistdimension,
109                                            newvar->var->v_readedlistdimension);
110        strcpy(curvar->var->v_commoninfile,newvar->var->v_commoninfile);
111     }
112     else
113     {
114         newvar = newvar->suiv;
115     }
116  }
117
118  return Globalite ;
119}
120
121int VariableIsInListCommon(listvar *curvar,listvar *listin)
122{
123  int present;
124  listvar *newvar;
125
126  present = 0;
127  newvar = listin;
128  while ( newvar && present == 0 )
129  {
130     if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) &&
131          !strcasecmp(newvar->var->v_subroutinename,
132                                    curvar->var->v_subroutinename)
133        )
134     {
135        CopyRecord(curvar->var,newvar->var);
136        present = 1;
137     }
138     else newvar = newvar->suiv;
139  }
140
141  return present;
142}
143
144int VariableIsInList(listvar *curvar,listvar *listin)
145{
146  int present;
147  listvar *newvar;
148
149  present = 0;
150  newvar = listin;
151  while ( newvar && present == 0 )
152  {
153     if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) )
154     {
155        CopyRecord(curvar->var,newvar->var);
156        present = 1;
157     }
158     else newvar = newvar->suiv;
159  }
160
161  return present;
162}
163
164/******************************************************************************/
165/*                      variableisglobalinmodule                              */
166/******************************************************************************/
167/* This subroutine is to know if a variable is global                         */
168/******************************************************************************/
169void variableisglobalinmodule(listcouple *listin, char *module, FILE *fileout, long int oldposcuruse)
170{
171  int Globalite;
172  listcouple *newvar;
173  listcouple *newvarprec;
174  listvar *tempo;
175  listvar *newvar2;
176  int out;
177  char truename[LONG_C]; 
178
179  Globalite = 1;
180  newvarprec = (listcouple *)NULL;
181  tempo = (listvar *)NULL;
182  tempo = Readthedependfile(module,tempo);
183  newvar = listin;
184
185  while ( newvar )
186  {
187     if (!strcmp(newvar->c_namepointedvar,"")) {
188       strcpy(truename,newvar->c_namevar);
189     }
190     else
191     {
192       strcpy(truename,newvar->c_namepointedvar);
193     }
194     
195     out = 0;
196     newvar2 = tempo;
197     while ( newvar2 && out == 0 )
198     {
199        if ( !strcasecmp(newvar2->var->v_nomvar,truename) ) out = 1;
200        else newvar2 = newvar2 ->suiv;
201     }
202     if ( out == 1 )
203     {
204        /* remove from the listin                                             */
205        if ( newvar == listin )
206        {
207           listin = listin->suiv;
208           newvar = listin;
209        }
210        else
211        {
212           newvarprec->suiv = newvar->suiv;
213           newvar = newvar->suiv;
214        }
215     }
216     else
217     {
218         newvarprec = newvar;
219         newvar = newvar->suiv;
220         Globalite = 0;
221     }
222  }
223  if ( Globalite == 0 || !newvar)
224  {
225     pos_end = setposcurname(fileout);
226     RemoveWordSET_0(fileout,oldposcuruse,
227                                pos_end-oldposcuruse);
228                                 
229     newvar = listin;
230     while ( newvar )
231     {
232        fprintf(fileout,"      USE %s, ONLY : %s \n",module,newvar->c_namevar);
233        newvar = newvar->suiv;
234     }
235  }
236}
237
238
239void Remove_Word_Contains_0()
240{
241   if ( firstpass == 0 )
242   {
243      RemoveWordCUR_0(fortranout,(long)(-9),9);
244   }
245}
246
247void Remove_Word_end_module_0(int modulenamelength)
248{
249   if ( firstpass == 0 )
250   {
251      RemoveWordCUR_0(fortranout,(long)(-modulenamelength-12),
252                                         modulenamelength+11);
253   }
254}
255
256void Write_Word_Contains_0()
257{
258   if ( firstpass == 0 )
259   {
260      fprintf(fortranout,"\n      contains\n");
261   }
262}
263
264
265void Write_Word_end_module_0()
266{
267   if ( firstpass == 0 )
268   {
269      fprintf(fortranout,"\n      end module %s",curmodulename);
270   }
271}
272
273void Add_Subroutine_For_Alloc(char *nom)
274{
275   listnom *parcours;
276   listnom *newvar;
277   int out;
278
279   newvar = (listnom *)malloc(sizeof(listnom));
280   strcpy(newvar->o_nom,nom);
281   Save_Length(nom,23);
282   newvar->suiv = NULL;
283
284   if ( !List_Subroutine_For_Alloc )
285   {
286      List_Subroutine_For_Alloc = newvar;
287   }
288   else
289   {
290      parcours = List_Subroutine_For_Alloc;
291      out = 0 ;
292      while ( parcours->suiv && out == 0 )
293      {
294         if ( !strcasecmp(parcours->o_nom,nom) ) out = 1 ;
295         else parcours = parcours ->suiv;
296      }
297      /*                                                                      */
298      if ( out == 0 )
299      {
300         if ( strcasecmp(parcours->o_nom,nom) ) parcours->suiv = newvar;
301      }
302   }
303}
304
305
306void Write_Alloc_Subroutine_0()
307{
308   listnom *parcours_nom;
309   listnom *parcours_nomprec;
310   int out;
311   char ligne[LONG_C];
312
313   if ( firstpass == 0 )
314   {
315      parcours_nomprec = (listnom *)NULL;
316      parcours_nom = List_NameOfModule;
317      out = 0 ;
318      while ( parcours_nom && out == 0 )
319      {
320         /*                                                                   */
321         if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1;
322         else parcours_nom = parcours_nom -> suiv;
323      }
324      if ( out == 1 )
325      {
326         if ( parcours_nom->o_val == 1 )
327         {
328            strcpy (ligne, "\n      PUBLIC Alloc_agrif_");
329            strcat (ligne, curmodulename);
330            strcat (ligne, "\n");
331            convert2lower(ligne);
332            fprintf(fortranout,ligne);
333         }
334      }
335      Write_Word_Contains_0();
336      if ( out == 1 )
337      {
338         if ( parcours_nom->o_val == 1 )
339         {
340            sprintf (ligne, "Subroutine Alloc_agrif_%s(Agrif_Gr)",
341                                                                 curmodulename);
342            tofich(fortranout,ligne,1);
343            strcpy(ligne,"Use Agrif_Util");
344            tofich(fortranout,ligne,1);
345            strcpy (ligne, "Type(Agrif_grid), Pointer :: Agrif_Gr");
346            tofich(fortranout,ligne,1);
347            strcpy(ligne, "INTEGER :: i");
348            tofich (fortranout, ligne,1);
349            strcpy (ligne, "\n#include \"alloc_agrif_");
350            strcat (ligne, curmodulename);
351            strcat (ligne, ".h\"\n");
352            convert2lower(ligne);
353            fprintf(fortranout,ligne);
354            strcpy (ligne, "Return");
355            tofich(fortranout,ligne,1);
356            sprintf (ligne, "End Subroutine Alloc_agrif_%s",curmodulename);
357            tofich(fortranout,ligne,1);
358            /* List all Call Alloc_agrif_                                     */
359            Add_Subroutine_For_Alloc(curmodulename);
360         }
361         else
362         {
363            parcours_nom = List_Subroutine_For_Alloc;
364            out = 0;
365            while ( parcours_nom && out == 0 )
366            {
367               if ( !strcasecmp(parcours_nom->o_nom,curmodulename) ) out = 1;
368               else
369               {
370                  parcours_nomprec = parcours_nom;
371                  parcours_nom = parcours_nom->suiv;
372               }
373            }
374            if ( out == 1 )
375            {
376               if ( parcours_nom == List_Subroutine_For_Alloc)
377               {
378                  List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv;
379               }
380               else
381               {
382                  parcours_nomprec->suiv = parcours_nom->suiv;
383                  parcours_nom = parcours_nomprec->suiv ;
384               }
385            }
386         }
387      }
388   }
389}
390
391
392void Write_Alloc_Subroutine_For_End_0()
393{
394   listnom *parcours_nom;
395   listnom *parcours_nomprec;
396   int out;
397   char ligne[LONG_C];
398
399   if ( firstpass == 0 )
400   {
401      parcours_nomprec = (listnom *)NULL;
402      parcours_nom = List_NameOfModule;
403      out = 0 ;
404      while ( parcours_nom && out == 0 )
405      {
406         /*                                                                   */
407         if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1;
408         else parcours_nom = parcours_nom -> suiv;
409      }
410      if ( out == 1 )
411      {
412         if ( parcours_nom->o_val == 1 )
413         {
414            strcpy (ligne, "\n      PUBLIC Alloc_agrif_");
415            strcat (ligne, curmodulename);
416            strcat (ligne, "\n");
417            convert2lower(ligne);
418            fprintf(fortranout,ligne);
419            strcpy (ligne, "\n      contains\n");
420            fprintf(fortranout,ligne);
421            sprintf (ligne, "Subroutine Alloc_agrif_%s(Agrif_Gr)",
422                                                                 curmodulename);
423            tofich(fortranout,ligne,1);
424            strcpy(ligne,"Use Agrif_Util");
425            tofich(fortranout,ligne,1);
426            strcpy (ligne, "Type(Agrif_grid), Pointer :: Agrif_Gr");
427            tofich(fortranout,ligne,1);
428            strcpy(ligne, "INTEGER :: i");
429            tofich (fortranout, ligne,1);
430            strcpy (ligne, "\n#include \"alloc_agrif_");
431            strcat (ligne, curmodulename);
432            strcat (ligne, ".h\"\n");
433            convert2lower(ligne);
434            fprintf(fortranout,ligne);
435            strcpy (ligne, "Return");
436            tofich(fortranout,ligne,1);
437            sprintf (ligne, "End Subroutine Alloc_agrif_%s",curmodulename);
438            tofich(fortranout,ligne,1);
439            /* List all Call Alloc_agrif                                      */
440            Add_Subroutine_For_Alloc(parcours_nom->o_nom);
441         }
442         else
443         {
444            parcours_nom = List_Subroutine_For_Alloc;
445            out = 0;
446            while ( parcours_nom && out == 0 )
447            {
448               if ( !strcasecmp(parcours_nom->o_nom,curmodulename) ) out = 1;
449               else
450               {
451                  parcours_nomprec = parcours_nom;
452                  parcours_nom = parcours_nom->suiv;
453               }
454            }
455            if ( out == 1 )
456            {
457               if ( parcours_nom == List_Subroutine_For_Alloc)
458               {
459                  List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv;
460               }
461               else
462               {
463                  parcours_nomprec->suiv = parcours_nom->suiv;
464                  parcours_nom = parcours_nomprec->suiv ;
465               }
466            }
467         }
468      }
469   }
470}
471
472void Write_GlobalParameter_Declaration_0()
473{
474   listvar *parcours;
475
476   if ( firstpass == 0 )
477   {
478      parcours = List_GlobalParameter_Var;
479      while( parcours )
480      {
481         if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
482         {
483            writevardeclaration(parcours,module_declar,0,1);
484         }
485         parcours = parcours -> suiv;
486      }
487   }
488}
489
490void Write_GlobalType_Declaration_0()
491{
492   listvar *parcours;
493   int out = 0;
494   int headtypewritten = 0;
495   char ligne[LONGNOM];
496   int changeval;
497
498   if ( firstpass == 0 )
499   {
500      parcours = List_Global_Var;
501      while( parcours )
502      {
503         if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
504         {
505           if (!strcasecmp(parcours->var->v_typevar,"type"))
506           {
507            out = 1;
508            if (headtypewritten == 0)
509              {
510                sprintf(ligne,"TYPE :: Agrif_%s",curmodulename);
511                tofich(module_declar,ligne,1);
512                headtypewritten = 1;
513              }
514            changeval = 0;
515            if (parcours->var->v_allocatable == 1)
516             {
517               changeval = 1;
518               parcours->var->v_allocatable = 0;
519               parcours->var->v_pointerdeclare = 1;
520             }
521            writevardeclaration(parcours,module_declar,0,0);
522            if (changeval == 1)
523              {
524               parcours->var->v_allocatable = 1;
525               parcours->var->v_pointerdeclare = 0;
526              }
527            }
528         }
529         parcours = parcours -> suiv;
530      }
531      if (out == 1)
532        {
533                sprintf(ligne,"END TYPE Agrif_%s",curmodulename);
534                tofich(module_declar,ligne,1);
535                sprintf(ligne,"TYPE(Agrif_%s), DIMENSION(:), ALLOCATABLE :: Agrif_%s_var",curmodulename,curmodulename); 
536                tofich(module_declar,ligne,1);
537        }
538   }
539}
540
541void Write_NotGridDepend_Declaration_0()
542{
543   listvar *parcours;
544
545   if ( firstpass == 0 )
546   {
547      parcours = List_NotGridDepend_Var;
548      while( parcours )
549      {
550         if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
551         {
552            writevardeclaration(parcours,fortranout,0,1);
553         }
554         parcours = parcours -> suiv;
555      }
556   }
557}
558
559/******************************************************************************/
560/*                          IsTabvarsUseInArgument_0                          */
561/******************************************************************************/
562/* Firstpass 1                                                                */
563/******************************************************************************/
564/*                                                                            */
565/******************************************************************************/
566int IsTabvarsUseInArgument_0()
567{
568   int out;
569   int doloopout;
570   listvar *parcours;
571
572   out=1;
573
574   if ( List_UsedInSubroutine_Var )
575   {
576      doloopout = 0;
577      parcours = List_UsedInSubroutine_Var;
578      while ( parcours && doloopout == 0 )
579      {
580         if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
581                                                                  doloopout = 1;
582         else parcours = parcours->suiv;
583      }
584      if (  doloopout == 0 ) out = 0;
585      else out = 1 ;
586   }
587   else out = 0;
588
589   return out;
590}
591
592
593/******************************************************************************/
594/*                        ImplicitNoneInSubroutine                            */
595/******************************************************************************/
596/* Firstpass 0                                                                */
597/******************************************************************************/
598/*                                                                            */
599/******************************************************************************/
600int ImplicitNoneInSubroutine()
601{
602  listname *parcours;
603  int out;
604
605  parcours= List_ImplicitNoneSubroutine;
606  out = 0 ;
607  while ( parcours && out == 0 )
608  {
609     if ( !strcasecmp(parcours->n_name,subroutinename) ) out = 1;
610     else parcours = parcours->suiv;
611  }
612  return out;
613}
614
615/******************************************************************************/
616/*                            Add_Pointer_Var_From_List_1                     */
617/******************************************************************************/
618/* Firstpass 1                                                                */
619/******************************************************************************/
620/*                                                                            */
621/******************************************************************************/
622void Add_Pointer_Var_From_List_1(listvar *listin)
623{
624   listvar *parcours;
625
626   if ( firstpass == 1 )
627   {
628       parcours = listin;
629       while ( parcours )
630       {
631          Add_Pointer_Var_1(parcours->var->v_nomvar);
632          parcours = parcours -> suiv ;
633       }
634   }
635}
636
637/******************************************************************************/
638/*                            Add_Pointer_Var_1                               */
639/******************************************************************************/
640/* Firstpass 1                                                                */
641/******************************************************************************/
642/*                                                                            */
643/******************************************************************************/
644void Add_Pointer_Var_1(char *nom)
645{
646   listname *newvar;
647   listname *parcours;
648   int out;
649
650   if ( firstpass == 1 )
651   {
652      if ( !List_Pointer_Var )
653      {
654         newvar = (listname *)malloc(sizeof(listname));
655         strcpy(newvar->n_name,nom);
656         Save_Length(nom,20);
657         newvar->suiv = NULL;
658         List_Pointer_Var = newvar;
659      }
660      else
661      {
662         parcours = List_Pointer_Var;
663         out = 0 ;
664         while ( parcours->suiv && out == 0 )
665         {
666            if (  !strcasecmp(parcours->n_name,nom) ) out = 1;
667            else
668               parcours=parcours->suiv;
669         }
670         if ( out == 0 )
671         {
672            if (  !strcasecmp(parcours->n_name,nom) ) out = 1;
673            else
674            {
675               /* add the record                                              */
676              newvar = (listname *)malloc(sizeof(listname));
677              strcpy(newvar->n_name,nom);
678              Save_Length(nom,20);
679              newvar->suiv = NULL;
680              parcours->suiv = newvar;
681            }
682         }
683      }
684   }
685}
686
687/******************************************************************************/
688/*                          varispointer_0                                    */
689/******************************************************************************/
690/* Firstpass 0                                                                */
691/******************************************************************************/
692/*                                                                            */
693/******************************************************************************/
694int varispointer_0(char *ident)
695{
696   listname *newname;
697   int out;
698
699   out =0;
700   if ( firstpass == 0 )
701   {
702      newname = List_Pointer_Var;
703      while( newname && out == 0 )
704      {
705         if ( !strcasecmp(ident,newname->n_name) ) out = 1 ;
706         else newname = newname->suiv;
707      }
708   }
709   return out;
710}
711
712/******************************************************************************/
713/*                          varistyped_0                                    */
714/******************************************************************************/
715/* Firstpass 0                                                                */
716/******************************************************************************/
717/*                                                                            */
718/******************************************************************************/
719int varistyped_0(char *ident)
720{
721   listvar *parcours;
722   int out;
723
724   out =0;
725   if ( firstpass == 0 )
726   {
727      parcours = List_Global_Var;
728      while( parcours && out == 0 )
729      {
730         if ( !strcasecmp(ident,parcours->var->v_nomvar) ) 
731             {
732             if (!strcasecmp(parcours->var->v_typevar,"type")) out = 1;
733             }
734         parcours = parcours->suiv;
735      }
736   }
737   return out;
738}
739
740
741/******************************************************************************/
742/*                          VariableIsNotFunction                             */
743/******************************************************************************/
744/*                                                                            */
745/******************************************************************************/
746int VariableIsNotFunction(char *ident)
747{
748   int out;
749   listvar *newvar;
750
751   out =0;
752
753   if ( !strcasecmp(ident,"size") ||
754        !strcasecmp(ident,"if")   ||
755        !strcasecmp(ident,"max")  ||
756        !strcasecmp(ident,"min")
757      )
758   {
759      newvar = List_SubroutineDeclaration_Var;
760      while ( newvar && out == 0 )
761      {
762         if ( !strcasecmp(subroutinename, newvar->var->v_subroutinename) &&
763              !strcasecmp(ident, newvar->var->v_nomvar) ) out = 1;
764         newvar = newvar -> suiv ;
765      }
766      if ( out == 1 ) out = 0;
767      else out = 1;
768      /* if it has not been found                                             */
769      if ( out == 1 )
770      {
771         out = 0;
772         newvar = List_Global_Var;
773         while ( newvar && out == 0 )
774         {
775            if ( !strcasecmp(ident, newvar->var->v_nomvar) ) out = 1;
776            newvar = newvar -> suiv ;
777         }
778         if ( out == 1 ) out = 0;
779         else out = 1;
780      }
781   }
782   /*                                                                         */
783   return out;
784}
Note: See TracBrowser for help on using the repository browser.