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/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/EXTERNAL/AGRIF/LIB – NEMO

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/EXTERNAL/AGRIF/LIB/Writedeclarations.c @ 6258

Last change on this file since 6258 was 6258, checked in by timgraham, 8 years ago

First inclusion of Laurent Debreu's modified code for vertical refinement.
Still a lot of outstanding issues:
1) conv preprocessor fails for limrhg.F90 at the moment (for now I've run without ice model)
2) conv preprocessor fails for STO code - removed this code from testing for now
3) conv preprocessor fails for cpl_oasis.F90 - can work round this by modifying code but the preprocessor should be fixed to deal with this.

After that code compiles and can be run for horizontal grid refinement. Not yet working for vertical refinement.

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.