New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
UtilFortran.c in vendors/AGRIF/current/LIB – NEMO

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

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

Load working_directory into vendors/AGRIF/current.

File size: 22.1 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/******************************************************************************/
45void initdimprob(int dimprobmod, const char * nx, const char * ny, const char* nz)
46{
47    dimprob = dimprobmod;
48
49    strcpy(nbmaillesX, nx);
50    strcpy(nbmaillesY, ny);
51    strcpy(nbmaillesZ, nz);
52}
53
54/******************************************************************************/
55/*                      Variableshouldberemoved                               */
56/******************************************************************************/
57/* Firstpass 0                                                                */
58/******************************************************************************/
59/*                                                                            */
60/*               Agrif_<toto>(variable) ====>     Agrif_<toto>(variable)      */
61/*                                                                            */
62/******************************************************************************/
63int Variableshouldberemoved(const char *nom)
64{
65    return Agrif_in_Tok_NAME(nom);
66}
67
68/******************************************************************************/
69/*                          variableisglobal                                  */
70/******************************************************************************/
71/* This subroutine is to know if a variable is global                         */
72/******************************************************************************/
73int variableisglobal(listvar *curvar, listvar *listin)
74{
75  int Globalite;
76  listvar *newvar;
77
78
79  Globalite = 0;
80  newvar = listin;
81  while ( newvar && Globalite == 0 )
82  {
83     if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) )
84     {
85        Globalite = 1;
86        /* Now we should give the definition of the variable in the           */
87        /* table List_UsedInSubroutine_Var                                    */
88        strcpy(curvar->var->v_typevar, newvar->var->v_typevar);
89        strcpy(curvar->var->v_dimchar, newvar->var->v_dimchar);
90        curvar->var->v_nbdim          = newvar->var->v_nbdim;
91        curvar->var->v_dimensiongiven = newvar->var->v_dimensiongiven;
92        curvar->var->v_allocatable    = newvar->var->v_allocatable;
93        curvar->var->v_target         = newvar->var->v_target;
94        curvar->var->v_catvar         = newvar->var->v_catvar;
95        curvar->var->v_pointerdeclare = newvar->var->v_pointerdeclare;
96        curvar->var->v_indicetabvars  = newvar->var->v_indicetabvars;
97        strcpy(curvar->var->v_nameinttypename, newvar->var->v_nameinttypename);
98        strcpy(curvar->var->v_precision, newvar->var->v_precision);
99        strcpy(curvar->var->v_readedlistdimension, newvar->var->v_readedlistdimension);
100        strcpy(curvar->var->v_commoninfile, newvar->var->v_commoninfile);
101     }
102     else
103     {
104         newvar = newvar->suiv;
105     }
106  }
107
108  return Globalite ;
109}
110
111int VariableIsInListCommon(listvar *curvar,listvar *listin)
112{
113  int present;
114  listvar *newvar;
115
116  present = 0;
117  newvar = listin;
118
119  while ( newvar && present == 0 )
120  {
121     if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) &&
122          !strcasecmp(newvar->var->v_subroutinename, curvar->var->v_subroutinename) )
123     {
124        strcpy(curvar->var->v_commoninfile,newvar->var->v_commoninfile);
125        Merge_Variables(curvar->var,newvar->var);
126        present = 1;
127     }
128     else newvar = newvar->suiv;
129  }
130
131  return present;
132}
133
134int VariableIsInList(listvar *curvar,listvar *listin)
135{
136  int present;
137  listvar *newvar;
138
139  present = 0;
140  newvar = listin;
141  while ( newvar && present == 0 )
142  {
143     if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) )
144     {
145        Merge_Variables(curvar->var,newvar->var);
146        present = 1;
147     }
148     else newvar = newvar->suiv;
149  }
150
151  return present;
152}
153
154/******************************************************************************/
155/*                      variableisglobalinmodule                              */
156/******************************************************************************/
157/* This subroutine is to know if a variable is global                         */
158/******************************************************************************/
159void variableisglobalinmodule(listcouple *listin, const char *module, FILE *fileout, long int oldposcuruse)
160{
161  int Globalite;
162  listcouple *newvar;
163  listcouple *newvarprec;
164  listvar *tempo;
165  listvar *newvar2;
166  int out;
167  char truename[LONG_VNAME];
168
169  Globalite = 1;
170  newvarprec = (listcouple *)NULL;
171  tempo = (listvar *)NULL;
172  tempo = Readthedependfile(module,tempo);
173  newvar = listin;
174
175  while ( newvar )
176  {
177     if (!strcmp(newvar->c_namepointedvar,"")) {
178       strcpy(truename,newvar->c_namevar);
179     }
180     else
181     {
182       strcpy(truename,newvar->c_namepointedvar);
183     }
184
185     out = 0;
186     newvar2 = tempo;
187     while ( newvar2 && out == 0 )
188     {
189        if ( !strcasecmp(newvar2->var->v_nomvar,truename) ) out = 1;
190        else newvar2 = newvar2 ->suiv;
191     }
192     if ( out == 1 )
193     {
194        /* remove from the listin                                             */
195        if ( newvar == listin )
196        {
197           listin = listin->suiv;
198           newvar = listin;
199        }
200        else
201        {
202           newvarprec->suiv = newvar->suiv;
203           newvar = newvar->suiv;
204        }
205     }
206     else
207     {
208         newvarprec = newvar;
209         newvar = newvar->suiv;
210         Globalite = 0;
211     }
212  }
213  if ( Globalite == 0 || !newvar)
214  {
215     pos_end = setposcurname(fileout);
216     RemoveWordSET_0(fileout,oldposcuruse,pos_end-oldposcuruse);
217
218     newvar = listin;
219     while ( newvar )
220     {
221        fprintf(fileout,"      use %s, only : %s \n",module,newvar->c_namevar);
222        newvar = newvar->suiv;
223     }
224  }
225}
226
227void Write_Word_end_module_0()
228{
229    if ( firstpass == 0 )
230    {
231        fprintf(fortran_out,"\n      end module %s",curmodulename);
232    }
233}
234
235void Add_Subroutine_For_Alloc(const char *nom)
236{
237   listnom *parcours;
238   listnom *newvar;
239   int out;
240
241   newvar = (listnom*) calloc(1, sizeof(listnom));
242   strcpy(newvar->o_nom,nom);
243   newvar->suiv = NULL;
244
245   if ( !List_Subroutine_For_Alloc )
246   {
247      List_Subroutine_For_Alloc = newvar;
248   }
249   else
250   {
251      parcours = List_Subroutine_For_Alloc;
252      out = 0 ;
253      while ( parcours->suiv && out == 0 )
254      {
255         if ( !strcasecmp(parcours->o_nom,nom) ) out = 1 ;
256         else parcours = parcours ->suiv;
257      }
258      /*                                                                      */
259      if ( out == 0 )
260      {
261         if ( strcasecmp(parcours->o_nom,nom) ) parcours->suiv = newvar;
262      }
263   }
264}
265
266void Write_Closing_Module(int forend)
267{
268    listvar *parcours;
269    listnom *parcours_nom;
270    listnom *parcours_nomprec;
271    variable *v;
272    int out = 0;
273    int headtypewritten = 0;
274    char ligne[LONG_M];
275    int changeval;
276
277    // Write Global Parameter Declaration
278    parcours = List_GlobalParameter_Var;
279    while( parcours )
280    {
281        if ( !strcasecmp(parcours->var->v_modulename, curmodulename) )
282        {
283            WriteVarDeclaration(parcours->var, module_declar, 0, 1);
284        }
285        parcours = parcours -> suiv;
286    }
287
288    // Write Global Type declaration
289    parcours = List_Global_Var;
290    while( parcours )
291    {
292        v = parcours->var;
293        if ( !strcasecmp(v->v_modulename, curmodulename) &&
294             !strcasecmp(v->v_typevar, "type") )
295        {
296            if ( headtypewritten == 0 )
297            {
298                fprintf(fortran_out, "\n      type Agrif_%s\n", curmodulename);
299                headtypewritten = 1;
300            }
301            changeval = 0;
302            if ( v->v_allocatable )
303            {
304                changeval = 1;
305                v->v_allocatable = 0;
306                v->v_pointerdeclare = 1;
307            }
308            WriteVarDeclaration(v, fortran_out, 0, 0);
309            if ( changeval )
310            {
311                v->v_allocatable = 1;
312                v->v_pointerdeclare = 0;
313            }
314            out = 1;
315        }
316        parcours = parcours -> suiv;
317    }
318    if (out == 1)
319    {
320        fprintf(fortran_out, "      end type Agrif_%s\n", curmodulename);
321        sprintf(ligne, "type(Agrif_%s), dimension(:), allocatable :: Agrif_%s_var",curmodulename, curmodulename);
322        tofich(fortran_out,ligne,1);
323        fprintf(fortran_out, "      public :: Agrif_%s\n", curmodulename);
324        fprintf(fortran_out, "      public :: Agrif_%s_var\n", curmodulename);
325    }
326
327    // Write NotGridDepend declaration
328    parcours = List_NotGridDepend_Var;
329    while( parcours )
330    {
331        if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
332        {
333            WriteVarDeclaration(parcours->var, fortran_out, 0, 1);
334        }
335        parcours = parcours -> suiv;
336    }
337
338    // Write Alloc_agrif_'modulename' subroutine
339    parcours_nomprec = (listnom*) NULL;
340    parcours_nom = List_NameOfModule;
341    out = 0 ;
342    while ( parcours_nom && out == 0 )
343    {
344        if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1;
345        else parcours_nom = parcours_nom -> suiv;
346    }
347    if ( ! out )
348    {
349        printf("#\n# Write_Closing_Module : OUT == 0   *** /!\\ ***\n");
350        printf("# FIXME: POSSIBLE BUG in CONV !!!\n#\n");
351    }
352    if ( out )
353    {
354        if ( parcours_nom->o_val == 1 )
355        {
356            fprintf(fortran_out,"\n      public :: Alloc_agrif_%s\n",curmodulename);
357        }
358        if ( (forend == 0) || (parcours_nom->o_val == 1) )
359        {
360           fprintf(fortran_out,"\n      contains\n");
361        }
362        if ( parcours_nom->o_val == 1 )
363        {
364            fprintf(fortran_out, "      subroutine Alloc_agrif_%s(Agrif_Gr)\n", curmodulename);
365            fprintf(fortran_out, "          use Agrif_Util\n");
366            fprintf(fortran_out, "          type(Agrif_grid), pointer :: Agrif_Gr\n");
367            fprintf(fortran_out, "          integer :: i\n");
368            fprintf(fortran_out, "\n#include \"alloc_agrif_%s.h\"\n", curmodulename);
369            fprintf(fortran_out, "      end subroutine Alloc_agrif_%s\n", curmodulename);
370            Add_Subroutine_For_Alloc(curmodulename);
371        }
372        else
373        {
374            parcours_nom = List_Subroutine_For_Alloc;
375            out = 0;
376            while ( parcours_nom && out == 0 )
377            {
378                if ( !strcasecmp(parcours_nom->o_nom, curmodulename) ) out = 1;
379                else
380                {
381                    parcours_nomprec = parcours_nom;
382                    parcours_nom = parcours_nom->suiv;
383                }
384            }
385            if ( out )
386            {
387                if ( parcours_nom == List_Subroutine_For_Alloc)
388                {
389                    List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv;
390                }
391                else
392                {
393                    parcours_nomprec->suiv = parcours_nom->suiv;
394                    parcours_nom = parcours_nomprec->suiv ;
395                }
396            }
397        }
398    }
399}
400
401/******************************************************************************/
402/*                          IsTabvarsUseInArgument_0                          */
403/******************************************************************************/
404/* Firstpass 1                                                                */
405/******************************************************************************/
406/*                                                                            */
407/******************************************************************************/
408int IsTabvarsUseInArgument_0()
409{
410   int out;
411   int doloopout;
412   listvar *parcours;
413
414   out=1;
415
416   if ( List_UsedInSubroutine_Var )
417   {
418      doloopout = 0;
419      parcours = List_UsedInSubroutine_Var;
420      while ( parcours && doloopout == 0 )
421      {
422         if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
423                                                                  doloopout = 1;
424         else parcours = parcours->suiv;
425      }
426      if (  doloopout == 0 ) out = 0;
427      else out = 1 ;
428   }
429   else out = 0;
430
431   return out;
432}
433
434
435/******************************************************************************/
436/*                        ImplicitNoneInSubroutine                            */
437/******************************************************************************/
438/* Firstpass 0                                                                */
439/******************************************************************************/
440/*                                                                            */
441/******************************************************************************/
442int ImplicitNoneInSubroutine()
443{
444  listname *parcours;
445  int out;
446
447  parcours= List_ImplicitNoneSubroutine;
448  out = 0 ;
449  while ( parcours && out == 0 )
450  {
451     if ( !strcasecmp(parcours->n_name,subroutinename) ) out = 1;
452     else parcours = parcours->suiv;
453  }
454  return out;
455}
456
457/******************************************************************************/
458/*                            Add_Pointer_Var_From_List_1                     */
459/******************************************************************************/
460/* Firstpass 1                                                                */
461/******************************************************************************/
462/*                                                                            */
463/******************************************************************************/
464void Add_Pointer_Var_From_List_1(listvar *listin)
465{
466   listvar *parcours;
467
468   if ( firstpass == 1 )
469   {
470       parcours = listin;
471       while ( parcours )
472       {
473          Add_Pointer_Var_1(parcours->var->v_nomvar);
474          parcours = parcours -> suiv ;
475       }
476   }
477}
478
479/******************************************************************************/
480/*                            Add_Pointer_Var_1                               */
481/******************************************************************************/
482/* Firstpass 1                                                                */
483/******************************************************************************/
484/*                                                                            */
485/******************************************************************************/
486void Add_Pointer_Var_1(char *nom)
487{
488   listname *newvar;
489   listname *parcours;
490   int out;
491
492   if ( firstpass == 1 )
493   {
494      if ( !List_Pointer_Var )
495      {
496         newvar = (listname*) calloc(1, sizeof(listname));
497         strcpy(newvar->n_name, nom);
498         newvar->suiv = NULL;
499         List_Pointer_Var = newvar;
500      }
501      else
502      {
503         parcours = List_Pointer_Var;
504         out = 0 ;
505         while ( parcours->suiv && out == 0 )
506         {
507            if (  !strcasecmp(parcours->n_name,nom) ) out = 1;
508            else
509               parcours=parcours->suiv;
510         }
511         if ( out == 0 )
512         {
513            if (  !strcasecmp(parcours->n_name,nom) ) out = 1;
514            else
515            {
516               /* add the record                                              */
517              newvar = (listname*) calloc(1, sizeof(listname));
518              strcpy(newvar->n_name,nom);
519              newvar->suiv = NULL;
520              parcours->suiv = newvar;
521            }
522         }
523      }
524   }
525}
526
527/******************************************************************************/
528/*                          varispointer_0                                    */
529/******************************************************************************/
530/* Firstpass 0                                                                */
531/******************************************************************************/
532/*                                                                            */
533/******************************************************************************/
534int varispointer_0(char *ident)
535{
536   listname *newname;
537   int out;
538
539   out =0;
540   if ( firstpass == 0 )
541   {
542      newname = List_Pointer_Var;
543      while( newname && out == 0 )
544      {
545         if ( !strcasecmp(ident,newname->n_name) ) out = 1 ;
546         else newname = newname->suiv;
547      }
548   }
549   return out;
550}
551
552/******************************************************************************/
553/*                          varistyped_0                                    */
554/******************************************************************************/
555/* Firstpass 0                                                                */
556/******************************************************************************/
557/*                                                                            */
558/******************************************************************************/
559int varistyped_0(char *ident)
560{
561   listvar *parcours;
562   int out;
563
564   out =0;
565   if ( firstpass == 0 )
566   {
567      parcours = List_Global_Var;
568      while( parcours && out == 0 )
569      {
570         if ( !strcasecmp(ident,parcours->var->v_nomvar) )
571             {
572             if (!strcasecmp(parcours->var->v_typevar,"type")) out = 1;
573             }
574         parcours = parcours->suiv;
575      }
576   }
577   return out;
578}
579
580
581/******************************************************************************/
582/*                          VariableIsFunction                                */
583/******************************************************************************/
584/*                                                                            */
585/******************************************************************************/
586int VariableIsFunction(const char *ident)
587{
588    int out;
589    listvar *newvar;
590
591    out = 0;
592
593    if ( !strcasecmp(ident,"size") ||
594         !strcasecmp(ident,"if")   ||
595         !strcasecmp(ident,"max")  ||
596         !strcasecmp(ident,"min")  )
597    {
598        newvar = List_SubroutineDeclaration_Var;
599        while ( newvar && out == 0 )
600        {
601            if ( !strcasecmp(subroutinename, newvar->var->v_subroutinename) &&
602                 !strcasecmp(ident, newvar->var->v_nomvar) )
603            {
604                out = 1;
605            }
606            newvar = newvar -> suiv ;
607        }
608        if ( out == 0 ) /* if it has not been found */
609        {
610            newvar = List_Global_Var;
611            while ( newvar && out == 0 )
612            {
613                if ( !strcasecmp(ident, newvar->var->v_nomvar) ) out = 1;
614                newvar = newvar -> suiv ;
615            }
616        }
617    }
618    return (out == 0);
619}
620
621void dump_var(const variable* var)
622{
623    fprintf(stderr, "   var->v_nomvar : %s\n",var->v_nomvar);
624    fprintf(stderr, "   var->v_indice : %d\n",var->v_indicetabvars);
625    fprintf(stderr, "   var->v_typevar: %s\n",var->v_typevar);
626    fprintf(stderr, "   var->v_catvar : %d\n",var->v_catvar);
627    fprintf(stderr, "   var->v_modulename: %s\n",var->v_modulename);
628    fprintf(stderr, "   var->v_subroutinename: %s\n",var->v_subroutinename);
629    fprintf(stderr, "   var->v_commonname: %s\n",var->v_commonname);
630    fprintf(stderr, "   var->v_commoninfile: %s\n",var->v_commoninfile);
631    fprintf(stderr, "   var->v_nbdim: %d\n",var->v_nbdim);
632    fprintf(stderr, "   var->v_common: %d\n",var->v_common);
633    fprintf(stderr, "   var->v_module: %d\n",var->v_module);
634    fprintf(stderr, "   var->v_initialvalue: %s\n",var->v_initialvalue);
635}
Note: See TracBrowser for help on using the repository browser.