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/CMEMS_2020/LIB – NEMO

source: vendors/AGRIF/CMEMS_2020/LIB/Writedeclarations.c @ 10088

Last change on this file since 10088 was 10088, checked in by rblod, 6 years ago

update conv

  • Property svn:keywords set to Id
File size: 28.1 KB
RevLine 
[1901]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/******************************************************************************/
[5656]52void WriteBeginDeclaration(variable *v, char line[LONG_M], int visibility)
[1901]53{
[5656]54  char tmpligne[LONG_M];
55  int precision_given ;
[1901]56
57  if ( !strcasecmp(v->v_typevar,"") )
58  {
[5656]59     printf("# WARNING : The type of the variable %s is unknown.\n", v->v_nomvar);
60     printf("#           CONV should define a type\n");
[1901]61  }
[5656]62
63  sprintf(line, "%s", v->v_typevar);
64  if ( v->v_c_star == 1 ) strcat(line, "*");
65
[1901]66  /* We should give the precision of the variable if it has been given        */
[5656]67  precision_given = 0;
[10088]68 
[1901]69  if ( strcasecmp(v->v_precision,"") )
70  {
[5656]71     sprintf(tmpligne, "(%s)", v->v_precision);
72     Save_Length(tmpligne, 49);
73     strcat(line, tmpligne);
74     precision_given = 1;
[1901]75  }
[5656]76
[1901]77  if (strcasecmp(v->v_dimchar,""))
78  {
79     sprintf(tmpligne,"(%s)",v->v_dimchar);
[5656]80     Save_Length(tmpligne, 49);
81     strcat(line,tmpligne);
[1901]82  }
[5656]83
84  if ((precision_given == 0) && ( strcasecmp(v->v_nameinttypename,"") ))
[1901]85  {
86     sprintf(tmpligne,"*%s",v->v_nameinttypename);
[5656]87     Save_Length(tmpligne, 49);
88     strcat(line,tmpligne);
[1901]89  }
90  if (strcasecmp (v->v_IntentSpec, ""))
91  {
[5656]92     sprintf(tmpligne,", intent(%s)", v->v_IntentSpec);
93     Save_Length(tmpligne, 49);
94     strcat(line,tmpligne);
[1901]95  }
[5656]96  if ( v->v_VariableIsParameter ) strcat(line, ", parameter");
97  if ( visibility )
[1901]98  {
[5656]99      if ( v->v_PublicDeclare  )  strcat(line, ", public");
100      if ( v->v_PrivateDeclare )  strcat(line, ", private");
[1901]101  }
[5656]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);
[1901]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/******************************************************************************/
[5656]122void WriteScalarDeclaration( variable *v, char line[LONG_M])
[1901]123{
[5656]124    strcat(line, " :: ");
125    strcat(line, v->v_nomvar);
[1901]126
[5656]127    if ( strcasecmp(v->v_vallengspec, "") ) strcat(line,v->v_vallengspec);
128    if ( v->v_VariableIsParameter )
129    {
130        strcat(line," = ");
[10088]131        strcat(line, v->v_initialvalue->n_name);
[5656]132    }
133    Save_Length(line, 45);
[1901]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/******************************************************************************/
[5656]148void WriteTableDeclaration(variable * v,char ligne[LONG_M],int tmpok)
[1901]149{
[5656]150    char newname[LONG_M];
[1901]151
[5656]152    strcat (ligne, ", dimension(");
[1901]153
[5656]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);
[1901]159
[5656]160        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_Common_Var));
161        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
[1901]162
[5656]163        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_ModuleUsed_Var));
[1901]164        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
165
[5656]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);
[1901]172
[5656]173    if ( v->v_VariableIsParameter == 1 )
174    {
175        strcat(ligne," = ");
[10088]176        strcat(ligne,v->v_initialvalue->n_name);
[5656]177    }
178    Save_Length(ligne,45);
[1901]179}
180
181/******************************************************************************/
[5656]182/*                        WriteVarDeclaration                                 */
[1901]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/******************************************************************************/
[5656]193void WriteVarDeclaration( variable *v, FILE *fileout, int value, int visibility )
[1901]194{
195  FILE *filecommon;
[5656]196  char ligne[LONG_M];
[1901]197
[5656]198  filecommon = fileout;
199
200  if ( v->v_save == 0 || inmodulemeet == 0 )
[1901]201  {
[5656]202     WriteBeginDeclaration(v, ligne, visibility);
[1901]203
[5656]204     if ( v->v_nbdim == 0 )
205        WriteScalarDeclaration(v, ligne);
206     else
207        WriteTableDeclaration(v, ligne, value);
[1901]208
[10088]209     if ( v->v_VariableIsParameter != 1 && v->v_initialvalue)
[1901]210     {
211        strcat(ligne," = ");
[10088]212        strcat(ligne,v->v_initialvalue->n_name);
[1901]213     }
[5656]214     tofich(filecommon, ligne, 1);
[1901]215  }
[5656]216  else
217    printf("-- in writevardeclaration : |%s| -- MHCHECK\n", v->v_nomvar);
[1901]218  Save_Length(ligne,45);
219}
220
221
[5656]222void WriteLocalParamDeclaration(FILE* tofile)
[1901]223{
[5656]224    listvar *parcours;
[1901]225
[5656]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    }
[1901]235}
236
[5656]237void WriteFunctionDeclaration(FILE* tofile, int value)
[1901]238{
[5656]239    listvar *parcours;
[1901]240
[5656]241    parcours = List_FunctionType_Var;
242    while ( parcours )
243    {
[10088]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     }
[5656]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    }
[1901]258}
259
260void WriteSubroutineDeclaration(int value)
261{
[5656]262    listvar *parcours;
263    variable *v;
[1901]264
[5656]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    }
[1901]285}
286
287void WriteArgumentDeclaration_beforecall()
288{
[5656]289    int position;
290    listnom *neededparameter;
291    FILE *paramtoamr;
292    listvar *parcours;
293    variable *v;
[10088]294    char *ligne;
295    size_t line_length;
296    int res;
297    int global_check;
[1901]298
[10088]299    ligne = (char*) calloc(LONG_M, sizeof(char));
300    line_length = LONG_M;
301   
302    global_check = 0;
303   
304   
[5656]305    fprintf(fortran_out,"#include \"Param_BeforeCall_%s.h\"\n",subroutinename);
[1901]306
[5656]307    sprintf(ligne,"Param_BeforeCall_%s.h",subroutinename);
308    paramtoamr = open_for_write(ligne);
[1901]309
[5656]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);
[10088]321            res = writedeclarationintoamr(List_Parameter_Var, paramtoamr,
322                                    v, v->v_subroutinename, &neededparameter, subroutinename, global_check);
[5656]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);
[10088]334        WriteVariablelist_subloop(&ligne,&line_length);
335        WriteVariablelist_subloop_Def(&ligne,&line_length);
[5656]336        strcat(ligne,")");
[10088]337
[5656]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);
[1901]362}
363
[5656]364void WriteArgumentDeclaration_Sort(FILE* tofile)
[1901]365{
[5656]366    int position = 1;
367    listvar *parcours;
[1901]368
[5656]369    parcours = List_SubroutineArgument_Var;
[10088]370   
[5656]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    }
[1901]382
[5656]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    }
[1901]394
[5656]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    }
[1901]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/******************************************************************************/
[10088]417int writedeclarationintoamr (listvar * deb_common, FILE *fileout,
[5656]418                              variable *var , const char *commonname,
[10088]419                           listnom **neededparameter, const char *name_common, int global_check)
[1901]420{
421  listvar *newvar;
422  variable *v;
[5656]423  char ligne[LONG_M];
[1901]424  int changeval;
425  int out;
426  int writeit;
427  listnom *parcours;
[10088]428  listname *parcours_name_array;
429  int res;
430 
431  res = 0;
[1901]432
433  /* we should list the needed parameter                                      */
[10088]434
[1901]435  if ( !strcasecmp(name_common,commonname) )
[10088]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
[1901]446  /*                                                                          */
[10088]447  parcours = *neededparameter;
448
[1901]449  while (parcours)
450  {
451     newvar = deb_common;
[2715]452
[1901]453     out = 0 ;
454     while ( newvar && out == 0 )
455     {
[10088]456        if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename))
[1901]457        {
458           out=1;
459        /* add the name to the list of needed parameter                       */
[10088]460           *neededparameter = DecomposeTheNameinlistnom(
461                 newvar->var->v_initialvalue->n_name,
462                 *neededparameter );
[1901]463        }
[10088]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        }
[1901]472        else newvar=newvar->suiv;
473     }
474     parcours=parcours->suiv;
475   }
476  /*                                                                          */
[10088]477  parcours = *neededparameter;
478 
[1901]479  while (parcours)
480  {
481     newvar = deb_common;
482     out = 0 ;
483     while ( newvar && out == 0 )
484     {
[10088]485        if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename))
[1901]486        {
487           out=1;
488        /* add the name to the list of needed parameter                       */
[10088]489           *neededparameter = DecomposeTheNameinlistnom(
490                 newvar->var->v_initialvalue->n_name,
491                 *neededparameter );
[1901]492        }
[10088]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        }
[1901]501        else newvar=newvar->suiv;
502     }
503     parcours=parcours->suiv;
504   }
[10088]505  parcours = *neededparameter;
[1901]506  while (parcours)
507  {
508     writeit = 0;
509     newvar = deb_common;
510     while ( newvar && writeit == 0 )
511     {
[10088]512        if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) &&
[2715]513            !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename) && parcours->o_val == 0 )
[1901]514        {
515           writeit=1;
516           parcours->o_val = 1;
517        }
[10088]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        }
[1901]524        else newvar = newvar->suiv;
525     }
526
527     if ( writeit == 1  )
528     {
529        changeval = 0;
530        v = newvar->var;
[2715]531//        if ( v->v_allocatable == 1 && strcasecmp(v->v_typevar,"type") )
532//        {
533//           changeval = 1;
534//           v->v_allocatable = 0;
535//        }
[5656]536        WriteBeginDeclaration(v, ligne, 1);
[1901]537        if ( v->v_nbdim == 0 ) WriteScalarDeclaration(v,ligne);
[5656]538        else WriteTableDeclaration(v, ligne, 1);
[1901]539
[5656]540        tofich(fileout, ligne, 1);
[1901]541        if ( changeval == 1 )
542        {
543           v->v_allocatable = 1;
544        }
[10088]545        res = 1;
[1901]546     }
547     else
548     {
549        if (  strncasecmp(parcours->o_nom,"mpi_",4) == 0 &&
550              shouldincludempif                     == 1 )
551        {
552           shouldincludempif = 0;
[5656]553           fprintf(fileout,"      include \'mpif.h\'\n");
[1901]554        }
555     }
556     parcours=parcours->suiv;
557  }
558  Save_Length(ligne,45);
[10088]559  return res;
[1901]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;
[5656]579  char ligne[LONG_M];
[1901]580
[5656]581//   tofich (fileout, "",1);
[1901]582  newvar = deb_common;
[2715]583
[1901]584  while (newvar)
585  {
586     if ( newvar->var->v_nbdim == 0 &&
587          !strcasecmp(newvar->var->v_subroutinename,subroutinename)  &&
[10088]588           (newvar->var->v_pointerdeclare >= 0 || !strcasecmp(newvar->var->v_typevar,"type")) )
[1901]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;
[5656]616  char ligne[LONG_M];
[1901]617  int changeval;
618
619  newvar = deb_common;
620  while (newvar)
621  {
[5656]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) &&
[10088]625          (v->v_pointerdeclare >= 0 || !strcasecmp(v->v_typevar,"type")) )
[1901]626     {
627        changeval = 0;
628        if ( v->v_allocatable == 1)
629        {
630          if (strcasecmp(v->v_typevar,"type"))
631           {
[2715]632      //     changeval = 1;
633      //     v->v_allocatable = 0;
[1901]634           }
635          else
636           {
637           changeval = 2;
638           v->v_allocatable = 0;
639           v->v_pointerdeclare = 1;
640           }
641        }
642
[5656]643        WriteBeginDeclaration(v, ligne, 1);
644        WriteTableDeclaration(v, ligne, 1);
[1901]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  }
[10088]651
[1901]652  Save_Length(ligne,45);
653}
654
655void ReWriteDeclarationAndAddTosubroutine_01(listvar *listdecl)
656{
[5656]657    listvar *parcours;
658    variable *v;
659    int out;
[1901]660
[5656]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);
[2715]672
[5656]673            if (firstpass == 0 && out == 0 && VariableIsParameter == 0 && SaveDeclare == 0)
674            {
[10088]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             
[5656]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        }
[1901]697    }
698}
[2715]699
700void ReWriteDataStatement_0(FILE * filout)
701{
[5656]702    listvar *parcours;
703    int out;
704    char ligne[LONG_M];
705    char initialvalue[LONG_M];
[10088]706    listname *parcours_name;
707   
[5656]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;
[2715]715
[5656]716            out = LookingForVariableInListGlobal(List_Global_Var,parcours->var);
717            if (out)   break;
718
[10088]719            strcpy(initialvalue,"");
720            parcours_name = parcours->var->v_initialvalue;
721            while (parcours_name)
[5656]722            {
[10088]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                }
[5656]730            }
731            else
732            {
[10088]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");
[5656]737            }
[10088]738            parcours_name=parcours_name->suiv;
739            }
[5656]740            sprintf(ligne,"data %s/%s/",parcours->var->v_nomvar,initialvalue);
741            tofich(filout,ligne,1);
[10088]742           
[5656]743            parcours = parcours->suiv;
744        }
745    }
[2715]746}
Note: See TracBrowser for help on using the repository browser.