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.
Writedeclarations.c in vendors/AGRIF/dev/LIB – NEMO

source: vendors/AGRIF/dev/LIB/Writedeclarations.c

Last change on this file was 14431, checked in by smasson, 3 years ago

agrif: merge AGRIF/dev_r14312_MPI_Interface into AGRIF/dev, ticket:2598#comment:21
  • Property svn:keywords set to Id
File size: 28.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
39#include "decl.h"
40
41/******************************************************************************/
42/*                         WriteBeginDeclaration                              */
43/******************************************************************************/
44/* This subroutine is used to write the begin of a declaration                */
45/* taken in a variable record                                                 */
46/*                                                                            */
47/******************************************************************************/
48/*                                                                            */
49/*       integer variable ----------->   INTEGER                              */
50/*                                                                            */
51/******************************************************************************/
52void WriteBeginDeclaration(variable *v, char line[LONG_M], int visibility)
53{
54  char tmpligne[LONG_M];
55  int precision_given ;
56
57  if ( !strcasecmp(v->v_typevar,"") )
58  {
59     printf("# WARNING : The type of the variable %s is unknown.\n", v->v_nomvar);
60     printf("#           CONV should define a type\n");
61  }
62
63  sprintf(line, "%s", v->v_typevar);
64  if ( v->v_c_star == 1 ) strcat(line, "*");
65
66  /* We should give the precision of the variable if it has been given        */
67  precision_given = 0;
68 
69  if ( strcasecmp(v->v_precision,"") )
70  {
71     sprintf(tmpligne, "(%s)", v->v_precision);
72     Save_Length(tmpligne, 49);
73     strcat(line, tmpligne);
74     precision_given = 1;
75  }
76
77  if (strcasecmp(v->v_dimchar,""))
78  {
79     sprintf(tmpligne,"(%s)",v->v_dimchar);
80     Save_Length(tmpligne, 49);
81     strcat(line,tmpligne);
82  }
83
84  if ((precision_given == 0) && ( strcasecmp(v->v_nameinttypename,"") ))
85  {
86     sprintf(tmpligne,"*%s",v->v_nameinttypename);
87     Save_Length(tmpligne, 49);
88     strcat(line,tmpligne);
89  }
90  if (strcasecmp (v->v_IntentSpec, ""))
91  {
92     sprintf(tmpligne,", intent(%s)", v->v_IntentSpec);
93     Save_Length(tmpligne, 49);
94     strcat(line,tmpligne);
95  }
96  if ( v->v_VariableIsParameter ) strcat(line, ", parameter");
97  if ( visibility )
98  {
99      if ( v->v_PublicDeclare  )  strcat(line, ", public");
100      if ( v->v_PrivateDeclare )  strcat(line, ", private");
101  }
102  if ( v->v_ExternalDeclare ) strcat(line, ", external");
103  if ( v->v_allocatable     ) strcat(line, ", allocatable");
104  if ( v->v_target          ) strcat(line, ", target");
105  if ( v->v_optionaldeclare ) strcat(line, ", optional");
106  if ( v->v_contiguousdeclare ) strcat(line, ", contiguous");
107  if ( v->v_pointerdeclare  ) strcat(line, ", pointer");
108  Save_Length(line, 45);
109}
110
111
112/******************************************************************************/
113/*                         WriteScalarDeclaration                             */
114/******************************************************************************/
115/* This subroutine is used to write a scalar declaration                      */
116/* taken in a variable record                                                 */
117/*                                                                            */
118/******************************************************************************/
119/*                                                                            */
120/*       integer variable ----------->   INTEGER :: VARIABLE                  */
121/*                                                                            */
122/******************************************************************************/
123void WriteScalarDeclaration( variable *v, char line[LONG_M])
124{
125    strcat(line, " :: ");
126    strcat(line, v->v_nomvar);
127
128    if ( strcasecmp(v->v_vallengspec, "") ) strcat(line,v->v_vallengspec);
129    if ( v->v_VariableIsParameter )
130    {
131        strcat(line," = ");
132        strcat(line, v->v_initialvalue->n_name);
133    }
134    Save_Length(line, 45);
135}
136
137/******************************************************************************/
138/*                         WriteTableDeclaration                              */
139/******************************************************************************/
140/* This subroutine is used to write a Table declaration                       */
141/* taken in a variable record                                                 */
142/*                                                                            */
143/******************************************************************************/
144/*                                                                            */
145/*  integer variable(nb) ----------->                                         */
146/*                      INTEGER, DIMENSION(1:nb) :: variable                  */
147/*                                                                            */
148/******************************************************************************/
149void WriteTableDeclaration(variable * v,char ligne[LONG_M],int tmpok)
150{
151    char newname[LONG_M];
152
153    strcat (ligne, ", dimension(");
154
155    if ( v->v_dimensiongiven == 1 && tmpok == 1 )   strcat(ligne,v->v_readedlistdimension);
156    if ( v->v_dimensiongiven == 1 && tmpok == 0 )
157    {
158        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(v->v_readedlistdimension,List_Global_Var));
159        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
160
161        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_Common_Var));
162        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
163
164        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_ModuleUsed_Var));
165        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
166
167        Save_Length(newname,47);
168        strcat(ligne,newname);
169    }
170    strcat(ligne, ") :: ");
171    strcat(ligne, v->v_nomvar);
172    if ( strcasecmp(vallengspec,"") ) strcat(ligne,v->v_vallengspec);
173
174    if ( v->v_VariableIsParameter == 1 )
175    {
176        strcat(ligne," = ");
177        strcat(ligne,v->v_initialvalue->n_name);
178    }
179    Save_Length(ligne,45);
180}
181
182/******************************************************************************/
183/*                        WriteVarDeclaration                                 */
184/******************************************************************************/
185/* This subroutine is used to write the initial declaration in the file       */
186/* fileout of a variable                                                      */
187/*                                                                            */
188/******************************************************************************/
189/*                                                                            */
190/*  integer variable(nb) ----------->                                         */
191/*                      INTEGER, DIMENSION(1:nb),Pointer :: variable          */
192/*                                                                            */
193/******************************************************************************/
194void WriteVarDeclaration( variable *v, FILE *fileout, int value, int visibility )
195{
196  FILE *filecommon;
197  char ligne[LONG_M];
198
199  filecommon = fileout;
200
201  if ( v->v_save == 0 || inmodulemeet == 0 )
202  {
203     WriteBeginDeclaration(v, ligne, visibility);
204
205     if ( v->v_nbdim == 0 )
206        WriteScalarDeclaration(v, ligne);
207     else
208        WriteTableDeclaration(v, ligne, value);
209
210     if ( v->v_VariableIsParameter != 1 && v->v_initialvalue)
211     {
212        strcat(ligne," = ");
213        strcat(ligne,v->v_initialvalue->n_name);
214     }
215     tofich(filecommon, ligne, 1);
216  }
217  else
218    printf("-- in writevardeclaration : |%s| -- MHCHECK\n", v->v_nomvar);
219  Save_Length(ligne,45);
220}
221
222
223void WriteLocalParamDeclaration(FILE* tofile)
224{
225    listvar *parcours;
226
227    parcours = List_Parameter_Var;
228    while ( parcours )
229    {
230        if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
231        {
232            WriteVarDeclaration(parcours->var, tofile, 0, 1);
233        }
234        parcours = parcours -> suiv;
235    }
236}
237
238void WriteFunctionDeclaration(FILE* tofile, int value)
239{
240    listvar *parcours;
241
242    parcours = List_FunctionType_Var;
243    while ( parcours )
244    {
245    if (!strcmp(parcours->var->v_typevar, ""))
246    {
247     /* Default type*/
248          if ( IsVariableReal(parcours->var->v_nomvar) == 1 )
249                                         strcpy(parcours->var->v_typevar,"REAL");
250          else strcpy(parcours->var->v_typevar,"INTEGER");
251     }
252        if ( !strcasecmp(parcours->var->v_subroutinename, subroutinename) &&
253              strcasecmp(parcours->var->v_typevar, "") )
254        {
255            WriteVarDeclaration(parcours->var, tofile, value, 1);
256        }
257        parcours = parcours -> suiv;
258    }
259}
260
261void WriteSubroutineDeclaration(int value)
262{
263    listvar *parcours;
264    variable *v;
265
266    parcours = List_SubroutineDeclaration_Var;
267    while ( parcours )
268    {
269        v = parcours->var;
270        if ( !strcasecmp(v->v_subroutinename, subroutinename)   &&
271             (v->v_save == 0)                                   &&
272             (v->v_VariableIsParameter == 0)                    &&
273             (v->v_common == 0) )
274        {
275            WriteVarDeclaration(v, fortran_out, value, 1);
276        }
277        else if ( !strcasecmp(v->v_subroutinename, subroutinename)  &&
278                  (v->v_save == 0)                                  &&
279                  (v->v_VariableIsParameter == 0)                   &&
280                  (v->v_common == 0) )
281        {
282            WriteVarDeclaration(v, fortran_out, value, 1);
283        }
284        parcours = parcours -> suiv;
285    }
286}
287
288void WriteArgumentDeclaration_beforecall()
289{
290    int position;
291    listnom *neededparameter;
292    FILE *paramtoamr;
293    listvar *parcours;
294    variable *v;
295    char *ligne;
296    size_t line_length;
297    int res;
298    int global_check;
299
300    ligne = (char*) calloc(LONG_M, sizeof(char));
301    line_length = LONG_M;
302   
303    global_check = 0;
304   
305   
306    fprintf(fortran_out,"#include \"Param_BeforeCall_%s.h\"\n",subroutinename);
307
308    sprintf(ligne,"Param_BeforeCall_%s.h",subroutinename);
309    paramtoamr = open_for_write(ligne);
310
311    neededparameter = (listnom * )NULL;
312    position = 1;
313    parcours = List_SubroutineArgument_Var;
314
315    while ( parcours )
316    {
317        v = parcours->var;
318        if ( !strcasecmp(v->v_subroutinename, subroutinename) && (v->v_positioninblock == position) )
319        {
320            position++;
321            WriteVarDeclaration(v, fortran_out, 0, 1);
322            res = writedeclarationintoamr(List_Parameter_Var, paramtoamr,
323                                    v, v->v_subroutinename, &neededparameter, subroutinename, global_check);
324            parcours = List_SubroutineArgument_Var;
325        }
326        else parcours = parcours -> suiv;
327    }
328
329    // Write interface for 'Sub_Loop_machin' in 'Param_BeforeCall_machin.h' when outside a module
330    if ( IsTabvarsUseInArgument_0() && (inmodulemeet == 0) && (inprogramdeclare == 0) )
331    {
332        fprintf(paramtoamr, "      interface\n");
333        if (isrecursive) sprintf(ligne,"  recursive subroutine Sub_Loop_%s(", subroutinename);
334        else             sprintf(ligne,"  subroutine Sub_Loop_%s(", subroutinename);
335        WriteVariablelist_subloop(&ligne,&line_length);
336        WriteVariablelist_subloop_Def(&ligne,&line_length);
337        strcat(ligne,")");
338
339        tofich(paramtoamr,ligne,1);
340
341        listusemodule *parcours_mod;
342        parcours_mod = List_NameOfModuleUsed;
343        while ( parcours_mod )
344        {
345            if ( !strcasecmp(parcours_mod->u_cursubroutine, subroutinename) )
346            {
347                fprintf(paramtoamr, "          use %s\n", parcours_mod->u_usemodule);
348            }
349            parcours_mod = parcours_mod->suiv;
350        }
351        fprintf(paramtoamr, "          implicit none\n");
352        WriteLocalParamDeclaration(paramtoamr);
353        writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var, paramtoamr);
354        writesub_loopdeclaration_tab(List_UsedInSubroutine_Var, paramtoamr);
355        WriteArgumentDeclaration_Sort(paramtoamr);
356        WriteFunctionDeclaration(paramtoamr, 1);
357
358        sprintf(ligne,"  end subroutine Sub_Loop_%s\n", subroutinename);
359        tofich(paramtoamr, ligne, 1);
360        fprintf(paramtoamr, "      end interface\n");
361    }
362    fclose(paramtoamr);
363}
364
365void WriteArgumentDeclaration_Sort(FILE* tofile)
366{
367    int position = 1;
368    listvar *parcours;
369
370    parcours = List_SubroutineArgument_Var;
371   
372    while ( parcours )
373    {
374        if ( !strcasecmp(parcours->var->v_subroutinename, subroutinename) &&
375                         parcours->var->v_positioninblock == position )
376        {
377            position = position + 1;
378            WriteVarDeclaration(parcours->var, tofile, 1, 1);
379            parcours = List_SubroutineArgument_Var;
380        }
381        else parcours = parcours -> suiv;
382    }
383
384    parcours = List_SubroutineArgument_Var;
385    while ( parcours )
386    {
387        if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
388                         parcours->var->v_positioninblock == 0           &&
389                        parcours->var->v_nbdim == 0 )
390        {
391            WriteVarDeclaration(parcours->var,tofile,1,1);
392        }
393        parcours = parcours -> suiv;
394    }
395
396    parcours = List_SubroutineArgument_Var;
397    while ( parcours )
398    {
399        if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
400                         parcours->var->v_positioninblock == 0           &&
401                         parcours->var->v_nbdim != 0 )
402        {
403            WriteVarDeclaration(parcours->var, tofile, 1, 1);
404        }
405        parcours = parcours -> suiv;
406    }
407}
408
409/******************************************************************************/
410/*                      writedeclarationintoamr                               */
411/******************************************************************************/
412/* This subroutine is used to write the declaration of parameters needed in   */
413/*    allocation subroutines creates in toamr.c                               */
414/******************************************************************************/
415/*                                                                            */
416/*                                                                            */
417/******************************************************************************/
418int writedeclarationintoamr (listvar * deb_common, FILE *fileout,
419                              variable *var , const char *commonname,
420                           listnom **neededparameter, const char *name_common, int global_check)
421{
422  listvar *newvar;
423  variable *v;
424  char ligne[LONG_M];
425  int changeval;
426  int out;
427  int writeit;
428  listnom *parcours;
429  listname *parcours_name_array;
430  int res;
431 
432  res = 0;
433
434  /* we should list the needed parameter                                      */
435
436  if ( !strcasecmp(name_common,commonname) )
437     {
438     *neededparameter = DecomposeTheNameinlistnom(var->v_readedlistdimension,*neededparameter);
439     parcours_name_array = var->v_initialvalue_array;
440     while (parcours_name_array)
441     {
442     *neededparameter = DecomposeTheNameinlistnom(parcours_name_array->n_name,*neededparameter);
443     parcours_name_array=parcours_name_array->suiv;
444     }
445     }
446
447  /*                                                                          */
448  parcours = *neededparameter;
449
450  while (parcours)
451  {
452     newvar = deb_common;
453
454     out = 0 ;
455     while ( newvar && out == 0 )
456     {
457        if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename))
458        {
459           out=1;
460        /* add the name to the list of needed parameter                       */
461           *neededparameter = DecomposeTheNameinlistnom(
462                 newvar->var->v_initialvalue->n_name,
463                 *neededparameter );
464        }
465        else if ( (global_check == 1) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_modulename,newvar->var->v_modulename))
466        {
467           out=1;
468        /* add the name to the list of needed parameter                       */
469           *neededparameter = DecomposeTheNameinlistnom(
470                 newvar->var->v_initialvalue->n_name,
471                 *neededparameter );
472        }
473        else newvar=newvar->suiv;
474     }
475     parcours=parcours->suiv;
476   }
477  /*                                                                          */
478  parcours = *neededparameter;
479 
480  while (parcours)
481  {
482     newvar = deb_common;
483     out = 0 ;
484     while ( newvar && out == 0 )
485     {
486        if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename))
487        {
488           out=1;
489        /* add the name to the list of needed parameter                       */
490           *neededparameter = DecomposeTheNameinlistnom(
491                 newvar->var->v_initialvalue->n_name,
492                 *neededparameter );
493        }
494        else if ( (global_check == 1) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_modulename,newvar->var->v_modulename))
495        {
496           out=1;
497        /* add the name to the list of needed parameter                       */
498           *neededparameter = DecomposeTheNameinlistnom(
499                 newvar->var->v_initialvalue->n_name,
500                 *neededparameter );
501        }
502        else newvar=newvar->suiv;
503     }
504     parcours=parcours->suiv;
505   }
506  parcours = *neededparameter;
507  while (parcours)
508  {
509     writeit = 0;
510     newvar = deb_common;
511     while ( newvar && writeit == 0 )
512     {
513        if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) &&
514            !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename) && parcours->o_val == 0 )
515        {
516           writeit=1;
517           parcours->o_val = 1;
518        }
519        else if ( (global_check == 1) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) &&
520            !strcasecmp(var->v_modulename,newvar->var->v_modulename) && parcours->o_val == 0 )
521        {
522           writeit=1;
523           parcours->o_val = 1;
524        }
525        else newvar = newvar->suiv;
526     }
527
528     if ( writeit == 1  )
529     {
530        changeval = 0;
531        v = newvar->var;
532//        if ( v->v_allocatable == 1 && strcasecmp(v->v_typevar,"type") )
533//        {
534//           changeval = 1;
535//           v->v_allocatable = 0;
536//        }
537        WriteBeginDeclaration(v, ligne, 1);
538        if ( v->v_nbdim == 0 ) WriteScalarDeclaration(v,ligne);
539        else WriteTableDeclaration(v, ligne, 1);
540
541        tofich(fileout, ligne, 1);
542        if ( changeval == 1 )
543        {
544           v->v_allocatable = 1;
545        }
546        res = 1;
547     }
548     else
549     {
550        if (  strncasecmp(parcours->o_nom,"mpi_",4) == 0 &&
551              shouldincludempif                     == 1 )
552        {
553           shouldincludempif = 0;
554           fprintf(fileout,"      include \'mpif.h\'\n");
555        }
556     }
557     parcours=parcours->suiv;
558  }
559  Save_Length(ligne,45);
560  return res;
561}
562
563
564/******************************************************************************/
565/*                       writesub_loopdeclaration_scalar                      */
566/******************************************************************************/
567/* This subroutine is used to write the declaration part of subloop           */
568/*    subroutines                                                             */
569/******************************************************************************/
570/*                                                                            */
571/*  integer variable(nb) ----------->                                         */
572/*                                                                            */
573/*          INTEGER, DIMENSION(1:nb)         :: variable                      */
574/*                                                                            */
575/******************************************************************************/
576void writesub_loopdeclaration_scalar (listvar * deb_common, FILE *fileout)
577{
578  listvar *newvar;
579  variable *v;
580  char ligne[LONG_M];
581
582//   tofich (fileout, "",1);
583  newvar = deb_common;
584
585  while (newvar)
586  {
587     if ( newvar->var->v_nbdim == 0 &&
588          !strcasecmp(newvar->var->v_subroutinename,subroutinename)  &&
589           (newvar->var->v_pointerdeclare >= 0 || !strcasecmp(newvar->var->v_typevar,"type")) )
590     {
591        v = newvar->var;
592        WriteBeginDeclaration(v,ligne,1);
593        WriteScalarDeclaration(v,ligne);
594        tofich (fileout, ligne,1);
595     }
596     newvar = newvar->suiv;
597  }
598  Save_Length(ligne,45);
599}
600
601/******************************************************************************/
602/*                       writesub_loopdeclaration_tab                         */
603/******************************************************************************/
604/* This subroutine is used to write the declaration part of subloop           */
605/*    subroutines                                                             */
606/******************************************************************************/
607/*                                                                            */
608/*  integer variable(nb) ----------->                                         */
609/*                                                                            */
610/*          INTEGER, DIMENSION(1:nb)         :: variable                      */
611/*                                                                            */
612/******************************************************************************/
613void writesub_loopdeclaration_tab (listvar * deb_common, FILE *fileout)
614{
615  listvar *newvar;
616  variable *v;
617  char ligne[LONG_M];
618  int changeval;
619
620  newvar = deb_common;
621  while (newvar)
622  {
623      v = newvar->var;
624//  printf("newvar = %s %d %s\n",newvar->var->v_nomvar,newvar->var->v_pointerdeclare,newvar->var->v_typevar);
625     if ( (v->v_nbdim != 0)  && !strcasecmp(v->v_subroutinename, subroutinename) &&
626          (v->v_pointerdeclare >= 0 || !strcasecmp(v->v_typevar,"type")) )
627     {
628        changeval = 0;
629        if ( v->v_allocatable == 1)
630        {
631          if (strcasecmp(v->v_typevar,"type"))
632           {
633      //     changeval = 1;
634      //     v->v_allocatable = 0;
635           }
636          else
637           {
638           changeval = 2;
639           v->v_allocatable = 0;
640           v->v_pointerdeclare = 1;
641           }
642        }
643
644        WriteBeginDeclaration(v, ligne, 1);
645        WriteTableDeclaration(v, ligne, 1);
646        tofich (fileout, ligne,1);
647        if ( changeval >= 1 ) v->v_allocatable = 1;
648        if ( changeval == 2 ) v->v_pointerdeclare = 0;
649     }
650     newvar = newvar->suiv;
651  }
652
653  Save_Length(ligne,45);
654}
655
656void ReWriteDeclarationAndAddTosubroutine_01(listvar *listdecl)
657{
658    listvar *parcours;
659    variable *v;
660    int out;
661
662    if ( insubroutinedeclare )
663    {
664        parcours = listdecl;
665        while ( parcours )
666        {
667            v = parcours->var;
668                          out = LookingForVariableInList(List_SubroutineArgument_Var, v);
669            if (out == 0) out = VariableIsInListCommon(parcours, List_Common_Var);
670            if (out == 0) out = LookingForVariableInList(List_Parameter_Var, v);
671            if (out == 0) out = LookingForVariableInList(List_FunctionType_Var, v);
672            if (out == 0) out = LookingForVariableInListGlobal(List_Global_Var, v);
673
674            if (firstpass == 0 && out == 0 && VariableIsParameter == 0 && SaveDeclare == 0)
675            {
676           
677            /* The type may has not been given if the variable was only declared with dimension */
678
679            if ( !strcasecmp(v->v_typevar,"") )
680            {
681                  if ( IsVariableReal(v->v_nomvar) == 1 )
682                                        strcpy(v->v_typevar,"REAL");
683                  else strcpy(v->v_typevar,"INTEGER");
684                  v->v_catvar = get_cat_var(v);
685             }
686             
687                WriteVarDeclaration(v, fortran_out, 1, 1);
688            }
689            if (firstpass == 1)
690            {
691                if (VariableIsParameter == 0 && SaveDeclare == 0)
692                {
693                    List_SubroutineDeclaration_Var = insertvar(List_SubroutineDeclaration_Var, v);
694                }
695            }
696            parcours = parcours->suiv;
697        }
698    }
699}
700
701void ReWriteDataStatement_0(FILE * filout)
702{
703    listvar *parcours;
704    int out;
705    char ligne[LONG_M];
706    char initialvalue[LONG_M];
707    listname *parcours_name;
708   
709    if (insubroutinedeclare == 1)
710    {
711        parcours = List_Data_Var_Cur ;
712        while (parcours)
713        {
714            out = VariableIsInListCommon(parcours,List_Common_Var);
715            if (out)   break;
716
717            out = LookingForVariableInListGlobal(List_Global_Var,parcours->var);
718            if (out)   break;
719
720            strcpy(initialvalue,"");
721            parcours_name = parcours->var->v_initialvalue;
722            while (parcours_name)
723            {
724            if (strncasecmp(parcours_name->n_name,"(/",2))
725            {
726                strcat(initialvalue,parcours_name->n_name);
727                if (parcours_name->suiv)
728                {
729                strcat(initialvalue,",");
730                }
731            }
732            else
733            {
734            printf("A TRAITER DANS REWRITEDATA STATEMETN ");
735            exit(1);
736                strncpy(initialvalue,&parcours_name->n_name[2],strlen(parcours_name->n_name)-4);
737                strcpy(&initialvalue[strlen(parcours_name->n_name)-4],"\0");
738            }
739            parcours_name=parcours_name->suiv;
740            }
741            sprintf(ligne,"data %s/%s/",parcours->var->v_nomvar,initialvalue);
742            tofich(filout,ligne,1);
743           
744            parcours = parcours->suiv;
745        }
746    }
747}
Note: See TracBrowser for help on using the repository browser.