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 branches/2017/dev_r8126_UKMO_AGRIF_vert_interp/NEMOGCM/EXTERNAL/AGRIF/LIB – NEMO

source: branches/2017/dev_r8126_UKMO_AGRIF_vert_interp/NEMOGCM/EXTERNAL/AGRIF/LIB/Writedeclarations.c @ 8139

Last change on this file since 8139 was 8139, checked in by timgraham, 7 years ago

Updates to conv library as received from Laurent - required for vertical refinement

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