source: vendors/AGRIF/current/LIB/UtilListe.c @ 4777

Last change on this file since 4777 was 4777, checked in by rblod, 7 years ago

Load working_directory into vendors/AGRIF/current.

File size: 24.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
41void Init_Variable(variable *var)
42{
43   strcpy(var->v_typevar            , "");
44   strcpy(var->v_nomvar             , "");
45   strcpy(var->v_oldname            , "");
46   strcpy(var->v_dimchar            , "");
47   strcpy(var->v_modulename         , "");
48   strcpy(var->v_commonname         , "");
49   strcpy(var->v_vallengspec        , "");
50   strcpy(var->v_nameinttypename    , "");
51   strcpy(var->v_commoninfile       , "");
52   strcpy(var->v_subroutinename     , "");
53   strcpy(var->v_precision          , "");
54   strcpy(var->v_initialvalue       , "");
55   strcpy(var->v_IntentSpec         , "");
56   strcpy(var->v_readedlistdimension, "");
57   var->v_nbdim               = 0 ;
58   var->v_common              = 0 ;
59   var->v_positioninblock     = 0 ;
60   var->v_module              = 0 ;
61   var->v_save                = 0 ;
62   var->v_catvar              = 0 ;
63   var->v_VariableIsParameter = 0 ;
64   var->v_PublicDeclare       = 0 ;
65   var->v_PrivateDeclare      = 0 ;
66   var->v_ExternalDeclare     = 0 ;
67   var->v_pointedvar          = 0 ;
68   var->v_notgrid             = 0 ;
69   var->v_dimensiongiven      = 0 ;
70   var->v_c_star              = 0 ;
71   var->v_indicetabvars       = 0 ;
72   var->v_pointerdeclare      = 0 ;
73   var->v_optionaldeclare     = 0 ;
74   var->v_allocatable         = 0 ;
75   var->v_target              = 0 ;
76   var->v_dimsempty           = 0 ;
77   var->v_dimension = (listdim *) NULL;
78}
79/******************************************************************************/
80/*                            AddListvartolistvar                             */
81/******************************************************************************/
82/* This subroutine is used to add a listvar l at the end of a listvar         */
83/* glob.                                                                      */
84/*                                                                            */
85/******************************************************************************/
86/*        _______     _______     _______     _______     _______             */
87/*       +      +    +      +    +      +    +      +    +      +             */
88/*       + glob +--->+ glob +--->+ glob +--->+ glob +--->+  l   +             */
89/*       +______+    +______+    +______+    +______+    +______+             */
90/*                                                                            */
91/******************************************************************************/
92listvar * AddListvarToListvar ( listvar *l, listvar *glob, int ValueFirstpass )
93{
94    listvar *newvar;
95    if ( firstpass == ValueFirstpass )
96    {
97        if ( !glob ) glob = l;
98        else
99        {
100            newvar = glob;
101            while (newvar->suiv)
102                newvar = newvar->suiv;
103            newvar->suiv = l;
104        }
105    }
106    return glob;
107}
108
109/******************************************************************************/
110/*                       CreateAndFillin_Curvar                               */
111/******************************************************************************/
112/* This subroutine is used to create the record corresponding to the          */
113/* list of declaration                                                        */
114/******************************************************************************/
115/*                                                                            */
116/******************************************************************************/
117void CreateAndFillin_Curvar(const char *type, variable *curvar)
118{
119    if ( !strcasecmp(type, "character") && strcasecmp(CharacterSize, "") )
120    {
121        strcpy(curvar->v_dimchar, CharacterSize);
122    }
123
124    /* On donne la precision de la variable si elle a ete donnee                */
125    curvar->v_c_star = 0;
126    if ( c_star == 1 )  curvar->v_c_star = 1;
127
128    strcpy(curvar->v_vallengspec,"");
129    if ( strcasecmp(vallengspec,"") )
130    {
131        strcpy(curvar->v_vallengspec,vallengspec);
132        Save_Length(vallengspec,8);
133    }
134
135    strcpy(curvar->v_precision,"");
136    if ( strcasecmp(NamePrecision,"") )
137    {
138        strcpy(curvar->v_precision,NamePrecision);
139        addprecision_derivedfromkind(curvar);
140        Save_Length(NamePrecision,12);
141    }
142    /* Si cette variable a ete declaree dans un module on met curvar->module=1  */
143    if ( inmoduledeclare == 1 || SaveDeclare == 1 )
144    {
145        curvar->v_module = 1;
146    }
147    /* Puis on donne le nom du module dans curvar->v_modulename                */
148    strcpy(curvar->v_modulename,curmodulename);
149    /* Si cette variable a ete initialisee                                     */
150    if (InitialValueGiven == 1 )
151    {
152        strcpy(curvar->v_initialvalue,InitValue);
153        Save_Length(InitValue,14);
154    }
155    /* Si cette variable est declaree en save                                  */
156    if (SaveDeclare == 1 && !strcasecmp(curvar->v_typevar,"type")) curvar->v_save = 1;
157
158    /* Si cette variable est v_allocatable                                     */
159    if (Allocatabledeclare == 1 ) curvar->v_allocatable=1;
160
161    /* Si cette variable est v_target                                     */
162    if (Targetdeclare == 1 ) curvar->v_target=1;
163
164    /* if INTENT spec has been given                                           */
165    if ( strcasecmp(IntentSpec,"") )
166    {
167        strcpy(curvar->v_IntentSpec,IntentSpec);
168        Save_Length(IntentSpec,13);
169    }
170}
171
172
173void addprecision_derivedfromkind(variable *curvar)
174{
175    listnom *parcours;
176    char kind[LONG_VNAME];
177    char kind_val[LONG_C];
178
179    sscanf(curvar->v_precision, "%100s =", kind_val);
180
181    if ( !strcasecmp(kind_val, "kind") )
182        sscanf(curvar->v_precision, "%50s = %50s", kind, kind_val);
183
184    parcours = listofkind;
185    while (parcours)
186    {
187        if ( !strcasecmp(parcours->o_nom, kind_val) )
188        {
189            sprintf(curvar->v_nameinttypename, "%d", parcours->o_val);
190        }
191        parcours=parcours->suiv;
192    }
193}
194
195/******************************************************************************/
196/*                        duplicatelistvar                                    */
197/******************************************************************************/
198/*                                                                            */
199/******************************************************************************/
200// void duplicatelistvar(listvar *orig)
201// {
202//    listvar *parcours;
203//    listvar *tmplistvar;
204//    listvar *tmplistvarprec;
205//    listdim *tmplistdim;
206//    variable *tmpvar;
207//
208//    tmplistvarprec = (listvar *)NULL;
209//    parcours = orig;
210//    while ( parcours )
211//    {
212//       tmplistvar = (listvar *)calloc(1,sizeof(listvar));
213//       tmpvar = (variable *)calloc(1,sizeof(variable));
214//       /*                                                                      */
215//       Init_Variable(tmpvar);
216//       /*                                                                      */
217//       strcpy(tmpvar->v_typevar, parcours->var->v_typevar);
218//       strcpy(tmpvar->v_nomvar,  parcours->var->v_nomvar);
219//       strcpy(tmpvar->v_oldname, parcours->var->v_oldname);
220//       strcpy(tmpvar->v_dimchar, parcours->var->v_dimchar);
221//       if ( parcours->var->v_dimension )
222//       {
223//          tmplistdim = (listdim*) calloc(1,sizeof(listdim));
224//          tmplistdim = parcours->var->v_dimension;
225//          tmpvar->v_dimension = tmplistdim;
226//       }
227//       tmpvar->v_nbdim  = parcours->var->v_nbdim;
228//       tmpvar->v_common = parcours->var->v_common;
229//       tmpvar->v_module = parcours->var->v_module;
230//       tmpvar->v_save   = parcours->var->v_save;
231//       tmpvar->v_positioninblock = parcours->var->v_positioninblock;
232//       tmpvar->v_VariableIsParameter = parcours->var->v_VariableIsParameter;
233//       tmpvar->v_indicetabvars = parcours->var->v_indicetabvars;
234//       tmpvar->v_pointedvar    = parcours->var->v_pointedvar;
235//       tmpvar->v_dimensiongiven = parcours->var->v_dimensiongiven;
236//       tmpvar->v_c_star = parcours->var->v_c_star;
237//       tmpvar->v_catvar = parcours->var->v_catvar;
238//       tmpvar->v_pointerdeclare = parcours->var->v_pointerdeclare;
239//       tmpvar->v_optionaldeclare = parcours->var->v_optionaldeclare;
240//       tmpvar->v_allocatable = parcours->var->v_allocatable;
241//       tmpvar->v_target      = parcours->var->v_target;
242//       tmpvar->v_dimsempty   = parcours->var->v_dimsempty;
243//       strcpy(tmpvar->v_modulename,  parcours->var->v_modulename);
244//       strcpy(tmpvar->v_commonname,  parcours->var->v_commonname);
245//       strcpy(tmpvar->v_vallengspec, parcours->var->v_vallengspec);
246//       strcpy(tmpvar->v_nameinttypename, parcours->var->v_nameinttypename);
247//       strcpy(tmpvar->v_commoninfile, cur_filename);
248//       strcpy(tmpvar->v_subroutinename, parcours->var->v_subroutinename);
249//       strcpy(tmpvar->v_precision, parcours->var->v_precision);
250//       strcpy(tmpvar->v_initialvalue, parcours->var->v_initialvalue);
251//       strcpy(tmpvar->v_IntentSpec, parcours->var->v_IntentSpec);
252//       strcpy(tmpvar->v_readedlistdimension, parcours->var->v_readedlistdimension);
253//
254//       tmplistvar->var = tmpvar;
255//       tmplistvar->suiv = NULL;
256//
257//       if ( !listduplicated )
258//       {
259//          listduplicated = tmplistvar;
260//          tmplistvarprec = listduplicated;
261//       }
262//       else
263//       {
264//          tmplistvarprec->suiv = tmplistvar;
265//          tmplistvarprec = tmplistvar;
266//       }
267//       parcours = parcours->suiv;
268//    }
269// }
270
271/******************************************************************************/
272/*                           insertdim                                        */
273/******************************************************************************/
274/* This subroutine is used to insert a record in a list of                    */
275/* struct : listdim                                                           */
276/******************************************************************************/
277/*        _______     _______     _______     _______     _______             */
278/*       +      +    +      +    +      +    +      +    +      +             */
279/*       + NEW  +--->+ lin  +--->+ lin  +--->+ lin  +--->+  lin +             */
280/*       +______+    +______+    +______+    +______+    +______+             */
281/*                                                                            */
282/******************************************************************************/
283listdim * insertdim(listdim *lin,typedim nom)
284{
285   listdim *newdim ;
286   listdim *parcours ;
287
288   newdim=(listdim *) calloc(1,sizeof(listdim));
289   newdim->dim=nom;
290   newdim->suiv=NULL;
291
292   if ( ! lin )
293   {
294      lin = newdim;
295   }
296   else
297   {
298      parcours = lin;
299      while ( parcours->suiv ) parcours=parcours->suiv;
300      parcours->suiv = newdim;
301   }
302
303   return lin;
304}
305
306/******************************************************************************/
307/*                            change_dim_char                                 */
308/******************************************************************************/
309/* This subroutine is used to change the dimension in the list lin            */
310/******************************************************************************/
311/*        _______     _______                 _______     _______             */
312/*       +  l   +    +  l   +                +  l   +    +   l  +             */
313/*       + old  +--->+ old  +--------------->+ lin  +--->+  lin +             */
314/*       +______+    +______+                +______+    +______+             */
315/*                                                                            */
316/******************************************************************************/
317void change_dim_char(listdim *lin,listvar * l)
318{
319   listvar *parcours_var;
320   variable *v;
321
322   parcours_var=l;
323   while(parcours_var)
324   {
325      v = parcours_var->var;
326      strcpy(v->v_dimchar,(lin->dim).last);
327      parcours_var=parcours_var->suiv;
328   }
329}
330
331
332/******************************************************************************/
333/*                              get_num_dims                                  */
334/******************************************************************************/
335/* This subroutine is used to know the dimension of a table                   */
336/******************************************************************************/
337/*                                                                            */
338/*             Dimension(jpi,jpj,jpk) ----------> get_num_dims = 3            */
339/*                                                                            */
340/******************************************************************************/
341int get_num_dims ( const listdim *d )
342{
343    listdim *parcours;
344    int compteur = 0;
345
346    parcours = (listdim *) d;
347    while(parcours)
348    {
349        compteur++;
350        parcours = parcours->suiv;
351    }
352    return compteur;
353}
354
355
356/******************************************************************************/
357/*                          CREATEVAR                                         */
358/******************************************************************************/
359/* This subroutine is used to create and initialized a record of the          */
360/*      struct : variable                                                     */
361/******************************************************************************/
362variable * createvar(const char *nom, listdim *d)
363{
364    variable *var;
365    listdim *dims;
366    char ligne[LONG_M];
367    char listdimension[LONG_M];
368
369    var = (variable *) calloc(1,sizeof(variable));
370
371    Init_Variable(var);
372
373    strcpy(listdimension,"");
374    strcpy(var->v_nomvar,nom);
375    strcpy(var->v_modulename,curmodulename);
376    strcpy(var->v_commoninfile,cur_filename);
377    strcpy(var->v_subroutinename,subroutinename);
378
379    if ( strcasecmp(nameinttypename,"") )
380    {
381        strcpy(var->v_nameinttypename,nameinttypename);
382    }
383
384    if ( optionaldeclare     == 1 ) var->v_optionaldeclare = 1;
385    if ( pointerdeclare      == 1 ) var->v_pointerdeclare = 1;
386    if ( VariableIsParameter == 1 ) var->v_VariableIsParameter = 1 ;
387    if ( PublicDeclare       == 1 ) var->v_PublicDeclare = 1 ;
388    if ( PrivateDeclare      == 1 ) var->v_PrivateDeclare = 1;
389    if ( ExternalDeclare     == 1 ) var->v_ExternalDeclare = 1;
390
391   var->v_dimension = d;
392
393   /* Creation of the string for the dimension of this variable               */
394    dimsempty = 1;
395    if ( d )
396    {
397        var->v_dimensiongiven = 1;
398        dims = d;
399        while (dims)
400        {
401            if ( strcasecmp(dims->dim.first,"") || strcasecmp(dims->dim.last,""))
402            {
403                dimsempty = 0;
404            }
405            sprintf(ligne,"%s:%s",dims->dim.first,dims->dim.last);
406            strcat(listdimension,ligne);
407            if ( dims->suiv )
408            {
409                strcat(listdimension,",");
410            }
411            dims = dims->suiv;
412        }
413        if ( dimsempty == 1 || GlobalDeclarationType == 1 ) var->v_dimsempty = 1;
414    }
415    strcpy(var->v_readedlistdimension,listdimension);
416    Save_Length(listdimension,15);
417    var->v_nbdim = get_num_dims(d);
418
419    return var;
420}
421
422/******************************************************************************/
423/*                            INSERTVAR                                       */
424/******************************************************************************/
425/* This subroutine is used to insert a record in a list of the                */
426/*      struct : listvar                                                      */
427/******************************************************************************/
428/*        _______     _______     _______     _______     _______             */
429/*       +      +    +      +    +      +    +      +    +      +             */
430/*       +  lin +--->+  lin +--->+ lin  +--->+ lin  +--->+ NEW  +             */
431/*       +______+    +______+    +______+    +______+    +______+             */
432/*                                                                            */
433/*                                                                            */
434/******************************************************************************/
435listvar * insertvar(listvar *lin,variable *v)
436{
437   listvar *newvar ;
438   listvar *tmpvar ;
439
440   newvar=(listvar *) calloc(1,sizeof(listvar));
441   newvar->var=v;
442   newvar->suiv = NULL;
443   if (!lin)
444   {
445      newvar->suiv=NULL;
446      lin = newvar;
447   }
448   else
449   {
450      tmpvar = lin ;
451      while (tmpvar->suiv)
452      {
453         tmpvar = tmpvar ->suiv ;
454      }
455      tmpvar -> suiv = newvar;
456   }
457   return lin;
458}
459
460/******************************************************************************/
461/*                             SETTYPE                                        */
462/******************************************************************************/
463/* This subroutine is used to give the same variable type at each             */
464/*      record of the list of the struct : listvar                            */
465/******************************************************************************/
466/*        _______     _______     _______     _______     _______             */
467/*       + REAL +    + REAL +    + REAL +    + REAL +    + REAL +             */
468/*       +  lin +--->+  lin +--->+ lin  +--->+ lin  +--->+ lin  +             */
469/*       +______+    +______+    +______+    +______+    +______+             */
470/*                                                                            */
471/*                                                                            */
472/******************************************************************************/
473listvar *settype(const char *nom, listvar *lin)
474{
475   listvar *newvar;
476   variable *v;
477
478   newvar = lin;
479   while (newvar)
480   {
481      v = newvar->var;
482      strcpy(v->v_typevar,nom);
483      v->v_catvar = get_cat_var(v);
484      newvar = newvar->suiv;
485   }
486   newvar = lin;
487   return newvar ;
488}
489
490/******************************************************************/
491/* printliste  */
492/* print the list given in argulent */
493/******************************************************************/
494
495void printliste(listvar * lin)
496{
497   listvar *newvar;
498   variable *v;
499
500   newvar=lin;
501   while (newvar)
502   {
503      v=newvar->var;
504      printf("nom = %s, allocatable = %d dim = %s\n",v->v_nomvar,v->v_allocatable,(v->v_dimension)->dim.last);
505      newvar=newvar->suiv;
506   }
507}
508
509/******************************************************************************/
510/*   IsinListe : return 1 if name nom is in list lin                          */
511/*                                                                            */
512/******************************************************************************/
513 int IsinListe(listvar *lin,char *nom)
514{
515   listvar *newvar;
516   variable *v;
517   int out ;
518
519   newvar=lin;
520   out = 0;
521   while (newvar && (out == 0))
522   {
523      v=newvar->var;
524      if (!strcasecmp(v->v_nomvar,nom) && !strcasecmp(v->v_subroutinename,subroutinename)) {
525      out = 1;
526      }
527      newvar=newvar->suiv;
528   }
529
530   return out ;
531}
532
533listname *Insertname(listname *lin,char *nom, int sens)
534{
535   listname *newvar ;
536   listname *tmpvar;
537
538   newvar=(listname *) calloc(1,sizeof(listname));
539   strcpy(newvar->n_name,nom);
540   newvar->suiv = NULL;
541   if (!lin)
542   {
543      newvar->suiv=NULL;
544      lin = newvar;
545   }
546   else
547   {
548      if (sens == 0)
549      {
550      tmpvar = lin ;
551      while (tmpvar->suiv)
552      {
553         tmpvar = tmpvar ->suiv ;
554      }
555      tmpvar -> suiv = newvar;
556      }
557      else
558      {
559      newvar->suiv = lin;
560      lin = newvar;
561      }
562   }
563   return lin;
564}
565
566listname *concat_listname(listname *l1, listname *l2)
567{
568   listname *tmpvar;
569
570   tmpvar = l1;
571   while (tmpvar->suiv)
572   {
573    tmpvar = tmpvar->suiv;
574   }
575
576   tmpvar->suiv = l2;
577
578   return l1;
579}
580
581void createstringfromlistname(char *ligne, listname *lin)
582{
583    listname *tmpvar;
584
585    strcpy(ligne,"");
586    tmpvar = lin;
587
588    while(tmpvar)
589    {
590        strcat(ligne,tmpvar->n_name);
591        if (tmpvar->suiv) strcat(ligne,",");
592        tmpvar=tmpvar->suiv;
593    }
594}
595
596/******************************************************************/
597/* printname  */
598/* print the list given in argulent */
599/******************************************************************/
600
601void printname(listname * lin)
602{
603   listname *newvar;
604
605   newvar=lin;
606   while (newvar)
607   {
608      printf("nom = %s \n",newvar->n_name);
609      newvar=newvar->suiv;
610   }
611}
612
613void removeglobfromlist(listname **lin)
614{
615  listname *parcours1;
616  listvar *parcours2;
617  listname * parcourspres;
618  int out;
619
620  parcours1 = *lin;
621  parcourspres = (listname *)NULL;
622
623  while (parcours1)
624  {
625  parcours2 = List_Global_Var;
626  out = 0;
627  while (parcours2 && out == 0)
628  {
629    if (!strcasecmp(parcours2->var->v_nomvar,parcours1->n_name))
630    {
631    out = 1;
632    }
633    parcours2 = parcours2->suiv;
634  }
635  if (out == 1)
636  {
637  if (parcours1 == *lin)
638   {
639   *lin = (*lin)->suiv;
640   parcours1 = *lin;
641   }
642   else
643   {
644   parcourspres->suiv = parcours1->suiv;
645   parcours1 = parcourspres->suiv;
646   }
647   }
648   else
649   {
650   parcourspres = parcours1;
651    parcours1 = parcours1->suiv;
652    }
653  }
654}
655
656void writelistpublic(listname *lin)
657{
658    listname *parcours1;
659    char ligne[LONG_M];
660
661    if (lin)
662    {
663        sprintf(ligne,"public :: ");
664        parcours1 = lin;
665
666        while ( parcours1 )
667        {
668            strcat(ligne, parcours1->n_name);
669            if ( parcours1->suiv ) strcat(ligne,", ");
670            parcours1 = parcours1->suiv;
671        }
672        tofich(fortran_out,ligne,1);
673    }
674}
675
676void Init_List_Data_Var()
677{
678    listvar *parcours;
679
680    parcours = List_Data_Var_Cur;
681
682    if (List_Data_Var_Cur)
683    {
684        while (parcours)
685        {
686            List_Data_Var_Cur = List_Data_Var_Cur->suiv;
687            free(parcours);
688            parcours = List_Data_Var_Cur;
689        }
690    }
691    List_Data_Var_Cur = NULL;
692}
693
694int get_cat_var(variable *var)
695{
696    if (!strcasecmp(var->v_typevar, "CHARACTER"))
697        return 1;
698    else if ((var->v_nbdim == 0 ) && (!strcasecmp(var->v_typevar, "REAL")))
699        return 2;
700    else if (!strcasecmp(var->v_typevar, "LOGICAL"))
701        return 3;
702    else if (!strcasecmp(var->v_typevar, "INTEGER"))
703        return 4;
704    else
705        return 0;
706}
Note: See TracBrowser for help on using the repository browser.