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

source: trunk/AGRIF/LIB/Writedeclarations.c @ 774

Last change on this file since 774 was 774, checked in by rblod, 16 years ago

Update Agrif, see ticket:#39

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.1 KB
Line 
1/******************************************************************************/
2/*                                                                            */
3/*     CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran)       */
4/*                                                                            */
5/* Copyright or   or Copr. Laurent Debreu (Laurent.Debreu@imag.fr)            */
6/*                        Cyril Mazauric (Cyril_Mazauric@yahoo.fr)            */
7/* This software is governed by the CeCILL-C license under French law and     */
8/* abiding by the rules of distribution of free software.  You can  use,      */
9/* modify and/ or redistribute the software under the terms of the CeCILL-C   */
10/* license as circulated by CEA, CNRS and INRIA at the following URL          */
11/* "http://www.cecill.info".                                                  */
12/*                                                                            */
13/* As a counterpart to the access to the source code and  rights to copy,     */
14/* modify and redistribute granted by the license, users are provided only    */
15/* with a limited warranty  and the software's author,  the holder of the     */
16/* economic rights,  and the successive licensors  have only  limited         */
17/* liability.                                                                 */
18/*                                                                            */
19/* In this respect, the user's attention is drawn to the risks associated     */
20/* with loading,  using,  modifying and/or developing or reproducing the      */
21/* software by the user in light of its specific status of free software,     */
22/* that may mean  that it is complicated to manipulate,  and  that  also      */
23/* therefore means  that it is reserved for developers  and  experienced      */
24/* professionals having in-depth computer knowledge. Users are therefore      */
25/* encouraged to load and test the software's suitability as regards their    */
26/* requirements in conditions enabling the security of their systems and/or   */
27/* data to be ensured and,  more generally, to use and operate it in the      */
28/* same conditions as regards security.                                       */
29/*                                                                            */
30/* The fact that you are presently reading this means that you have had       */
31/* knowledge of the CeCILL-C license and that you accept its terms.           */
32/******************************************************************************/
33/* version 1.7                                                                */
34/******************************************************************************/
35#include <stdio.h>
36#include <stdlib.h>
37#include <string.h>
38
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 ligne[LONG_4C])
53{
54  char tmpligne[LONG_4C];
55
56  if ( !strcasecmp(v->v_typevar,"") )
57  {
58     printf("WARNING : The type of the variable %s \n",v->v_nomvar);
59     printf("          is unknown. CONV should define a type\n");
60  }
61  sprintf (ligne, "%s", v->v_typevar);
62  if ( v->v_c_star == 1 ) strcat(ligne,"*");
63  /* We should give the precision of the variable if it has been given        */
64  if ( strcasecmp(v->v_precision,"") )
65  {
66     sprintf(tmpligne,"(%s)",v->v_precision);
67     Save_Length(tmpligne,49);
68     strcat(ligne,tmpligne);
69  }
70  if (strcasecmp(v->v_dimchar,""))
71  {
72     sprintf(tmpligne,"(%s)",v->v_dimchar);
73     Save_Length(tmpligne,49);
74     strcat(ligne,tmpligne);
75  }
76  if ( strcasecmp(v->v_nameinttypename,"") )
77  {
78     sprintf(tmpligne,"*%s",v->v_nameinttypename);
79     Save_Length(tmpligne,49);
80     strcat(ligne,tmpligne);
81  }
82  if (strcasecmp (v->v_IntentSpec, ""))
83  {
84     sprintf(tmpligne,",INTENT(%s) ",v->v_IntentSpec);
85     Save_Length(tmpligne,49);
86     strcat(ligne,tmpligne);
87  }
88  if ( v->v_VariableIsParameter == 1 ) strcat(ligne, ", PARAMETER");
89  if ( v->v_PublicDeclare       == 1 ) strcat(ligne, ", PUBLIC");
90  if ( v->v_PrivateDeclare      == 1 ) strcat(ligne, ", PRIVATE");
91  if ( v->v_ExternalDeclare     == 1 ) strcat(ligne, ", EXTERNAL");
92  if ( v->v_allocatable         == 1 &&
93       v->v_save                == 0 ) strcat(ligne,", ALLOCATABLE");
94  if ( v->v_optionaldeclare     == 1 ) strcat(ligne,", OPTIONAL");
95  if ( v->v_pointerdeclare      == 1 ) strcat(ligne,", POINTER");
96  Save_Length(ligne,45);
97}
98
99
100/******************************************************************************/
101/*                         WriteScalarDeclaration                             */
102/******************************************************************************/
103/* This subroutine is used to write a scalar declaration                      */
104/* taken in a variable record                                                 */
105/*                                                                            */
106/******************************************************************************/
107/*                                                                            */
108/*       integer variable ----------->   INTEGER :: VARIABLE                  */
109/*                                                                            */
110/******************************************************************************/
111void WriteScalarDeclaration(variable *v,char ligne[LONG_4C])
112{
113
114  strcat (ligne, " :: ");
115  strcat (ligne, v->v_nomvar);
116  if ( strcasecmp(v->v_vallengspec,"") ) strcat(ligne,v->v_vallengspec);
117  if ( v->v_VariableIsParameter == 1 )
118  {
119     strcat(ligne," = ");
120     strcat(ligne,v->v_initialvalue);
121  }
122  Save_Length(ligne,45);
123}
124
125
126/******************************************************************************/
127/*                         WriteTableDeclaration                              */
128/******************************************************************************/
129/* This subroutine is used to write a Table declaration                       */
130/* taken in a variable record                                                 */
131/*                                                                            */
132/******************************************************************************/
133/*                                                                            */
134/*  integer variable(nb) ----------->                                         */
135/*                      INTEGER, DIMENSION(1:nb) :: variable                  */
136/*                                                                            */
137/******************************************************************************/
138void WriteTableDeclaration(variable * v,char ligne[LONG_4C],int tmpok)
139{
140  char newname[LONG_4C];
141
142  strcat (ligne, ", Dimension(");
143  if ( v->v_dimensiongiven == 1 && tmpok == 1 )
144                                         strcat(ligne,v->v_readedlistdimension);
145  if ( v->v_dimensiongiven == 1 && tmpok == 0 )
146  {
147     strcpy(newname,ChangeTheInitalvaluebyTabvarsName
148                                  (v->v_readedlistdimension,List_Global_Var,0));
149     if ( !strcasecmp(newname,v->v_readedlistdimension) )
150     {
151        strcpy(newname,"");
152        strcpy(newname,ChangeTheInitalvaluebyTabvarsName
153                                 (v->v_readedlistdimension,List_Common_Var,0));
154        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
155     }
156     if ( !strcasecmp(newname,v->v_readedlistdimension) )
157     {
158        strcpy(newname,"");
159        /* la liste des use de cette subroutine                               */
160        strcpy(newname,ChangeTheInitalvaluebyTabvarsName
161                              (v->v_readedlistdimension,List_ModuleUsed_Var,0));
162        if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension);
163     }
164     Save_Length(newname,47);
165     strcat(ligne,newname);
166  }
167  strcat (ligne, ")");
168  strcat (ligne, " :: ");
169  strcat (ligne, v->v_nomvar);
170  if ( strcasecmp(vallengspec,"") ) strcat(ligne,v->v_vallengspec);
171
172  if ( v->v_VariableIsParameter == 1 )
173  {
174     strcat(ligne," = ");
175     strcat(ligne,v->v_initialvalue);
176  }
177  Save_Length(ligne,45);
178}
179
180/******************************************************************************/
181/*                        writevardeclaration                                 */
182/******************************************************************************/
183/* This subroutine is used to write the initial declaration in the file       */
184/* fileout of a variable                                                      */
185/*                                                                            */
186/******************************************************************************/
187/*                                                                            */
188/*  integer variable(nb) ----------->                                         */
189/*                      INTEGER, DIMENSION(1:nb),Pointer :: variable          */
190/*                                                                            */
191/******************************************************************************/
192void writevardeclaration (listvar * var_record, FILE *fileout, int value)
193{
194  FILE *filecommon;
195  listvar *newvar;
196  variable *v;
197  char ligne[LONG_4C];
198
199  filecommon=fileout;
200  newvar = var_record;
201
202  if ( newvar->var->v_save == 0 || inmodulemeet == 0 )
203  {
204     v = newvar->var;
205     WriteBeginDeclaration(v,ligne);
206     if ( v->v_nbdim == 0 ) WriteScalarDeclaration(v,ligne);
207     else WriteTableDeclaration(v,ligne,value);
208
209     if ( v->v_VariableIsParameter != 1 && strcasecmp(v->v_initialvalue,"") )
210     {
211        strcat(ligne," = ");
212        strcat(ligne,v->v_initialvalue);
213     }
214     tofich (filecommon, ligne,1);
215  }
216  Save_Length(ligne,45);
217}
218
219
220void WriteLocalParamDeclaration()
221{
222   listvar *parcours;
223
224   parcours = List_Parameter_Var;
225   while ( parcours )
226   {
227      if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
228      {
229         writevardeclaration(parcours,fortranout,0);
230      }
231      parcours = parcours -> suiv;
232   }
233}
234
235void WriteFunctionDeclaration()
236{
237   listvar *parcours;
238
239   parcours = List_FunctionType_Var;
240   while ( parcours )
241   {
242      if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
243            strcasecmp(parcours->var->v_typevar,"")
244         )
245      {
246         writevardeclaration(parcours,fortranout,0);
247      }
248      parcours = parcours -> suiv;
249   }
250}
251
252void WriteSubroutineDeclaration(int value)
253{
254   listvar *parcours;
255
256   parcours = List_SubroutineDeclaration_Var;
257   while ( parcours )
258   {
259      if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
260           parcours->var->v_save == 0                                  &&
261           parcours->var->v_allocatable == 0                           &&
262           parcours->var->v_pointerdeclare == 0                        &&
263           parcours->var->v_VariableIsParameter == 0                   &&
264           parcours->var->v_common == 0
265         )
266      {
267         writevardeclaration(parcours,fortranout,value);
268      }
269      else if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
270           parcours->var->v_save == 0                                  &&
271           parcours->var->v_VariableIsParameter == 0                   &&
272           parcours->var->v_common == 0
273              )
274      {
275         writevardeclaration(parcours,fortranout,value);
276      }
277      parcours = parcours -> suiv;
278   }
279}
280
281void WriteArgumentDeclaration_beforecall()
282{
283   int position;
284   listnom *neededparameter;
285   FILE *paramtoamr;
286   listvar *newvar;
287   char ligne[LONG_4C];
288
289   fprintf(fortranout,"#include \"Param_BeforeCall_%s.h\" \n",subroutinename);
290   /*                                                                         */
291   sprintf(ligne,"Param_BeforeCall_%s.h",subroutinename);
292   paramtoamr = associate (ligne);
293   /*                                                                         */
294   neededparameter = (listnom * )NULL;
295   /*                                                                         */
296   position = 1;
297   newvar = List_SubroutineArgument_Var;
298   while ( newvar )
299   {
300      if ( !strcasecmp(newvar->var->v_subroutinename,subroutinename) &&
301                       newvar->var->v_positioninblock == position
302         )
303      {
304         position = position + 1;
305         writevardeclaration(newvar,fortranout,0);
306         neededparameter = writedeclarationintoamr(List_Parameter_Var,
307                   paramtoamr,newvar->var,newvar->var->v_subroutinename,
308                   neededparameter,subroutinename);
309
310         newvar = List_SubroutineArgument_Var;
311      }
312      else newvar = newvar -> suiv;
313   }
314   Save_Length(ligne,45);
315   fclose(paramtoamr);
316}
317
318void WriteArgumentDeclaration_Sort()
319{
320   int position;
321   listvar *newvar;
322
323   /*                                                                         */
324   position = 1;
325   newvar = List_SubroutineArgument_Var;
326   while ( newvar )
327   {
328      if ( !strcasecmp(newvar->var->v_subroutinename,subroutinename) &&
329                       newvar->var->v_positioninblock == position
330         )
331      {
332         position = position + 1;
333         writevardeclaration(newvar,fortranout,1);
334         /*                                                                   */
335         newvar = List_SubroutineArgument_Var;
336      }
337      else newvar = newvar -> suiv;
338   }
339   /*                                                                         */
340   newvar = List_SubroutineArgument_Var;
341   while ( newvar )
342   {
343      if ( !strcasecmp(newvar->var->v_subroutinename,subroutinename) &&
344                       newvar->var->v_positioninblock == 0           &&
345                       newvar->var->v_nbdim == 0
346         )
347      {
348         writevardeclaration(newvar,fortranout,1);
349      }
350      newvar = newvar -> suiv;
351   }
352   /*                                                                         */
353   newvar = List_SubroutineArgument_Var;
354   while ( newvar )
355   {
356      if ( !strcasecmp(newvar->var->v_subroutinename,subroutinename) &&
357                       newvar->var->v_positioninblock == 0           &&
358                       newvar->var->v_nbdim != 0
359         )
360      {
361         writevardeclaration(newvar,fortranout,1);
362      }
363      newvar = newvar -> suiv;
364   }
365}
366
367/******************************************************************************/
368/*                      writedeclarationintoamr                               */
369/******************************************************************************/
370/* This subroutine is used to write the declaration of parameters needed in   */
371/*    allocation subroutines creates in toamr.c                               */
372/******************************************************************************/
373/*                                                                            */
374/*                                                                            */
375/******************************************************************************/
376listnom *writedeclarationintoamr (listvar * deb_common, FILE *fileout,
377                              variable *var , char commonname[LONG_C],
378                           listnom *neededparameter, char name_common[LONG_C])
379{
380  listvar *newvar;
381  variable *v;
382  char ligne[LONG_4C];
383  int changeval;
384  int out;
385  int writeit;
386  listnom *parcours;
387  listnom *parcoursprec;
388
389  parcoursprec = (listnom * )NULL;
390  /* we should list the needed parameter                                      */
391  if ( !strcasecmp(name_common,commonname) )
392     neededparameter = DecomposeTheNameinlistnom(var->v_readedlistdimension,
393                                                               neededparameter);
394  /*                                                                          */
395  parcours = neededparameter;
396  while (parcours)
397  {
398     newvar = deb_common;
399     out = 0 ;
400     while ( newvar && out == 0 )
401     {
402        if ( !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) )
403        {
404           out=1;
405        /* add the name to the list of needed parameter                       */
406           neededparameter = DecomposeTheNameinlistnom(
407                 newvar->var->v_initialvalue,
408                 neededparameter );
409        }
410        else newvar=newvar->suiv;
411     }
412     parcours=parcours->suiv;
413   }
414  /*                                                                          */
415  parcours = neededparameter;
416  while (parcours)
417  {
418     newvar = deb_common;
419     out = 0 ;
420     while ( newvar && out == 0 )
421     {
422        if ( !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) )
423        {
424           out=1;
425        /* add the name to the list of needed parameter                       */
426           neededparameter = DecomposeTheNameinlistnom(
427                 newvar->var->v_initialvalue,
428                 neededparameter );
429        }
430        else newvar=newvar->suiv;
431     }
432     parcours=parcours->suiv;
433   }
434  /*                                                                          */
435  tofich (fileout, "",1);
436  parcours = neededparameter;
437  while (parcours)
438  {
439     writeit = 0;
440     newvar = deb_common;
441     while ( newvar && writeit == 0 )
442     {
443        if ( !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) &&
444             parcours->o_val == 0 )
445        {
446           writeit=1;
447           parcours->o_val = 1;
448        }
449        else newvar = newvar->suiv;
450     }
451
452     if ( writeit == 1  )
453     {
454        changeval = 0;
455        v = newvar->var;
456        if ( v->v_allocatable == 1  )
457        {
458           changeval = 1;
459           v->v_allocatable = 0;
460        }
461        WriteBeginDeclaration(v,ligne);
462        if ( v->v_nbdim == 0 ) WriteScalarDeclaration(v,ligne);
463        else WriteTableDeclaration(v,ligne,1);
464
465        tofich (fileout, ligne,1);
466        if ( changeval == 1 )
467        {
468           v->v_allocatable = 1;
469        }
470     }
471     else
472     {
473        if (  strncasecmp(parcours->o_nom,"mpi_",4) == 0 &&
474              shouldincludempif                     == 1 )
475        {
476           shouldincludempif = 0;
477           fprintf(fileout,"      include \'mpif.h\' \n");
478        }
479     }
480     parcours=parcours->suiv;
481  }
482  Save_Length(ligne,45);
483  return neededparameter;
484}
485
486
487/******************************************************************************/
488/*                       writesub_loopdeclaration_scalar                      */
489/******************************************************************************/
490/* This subroutine is used to write the declaration part of subloop           */
491/*    subroutines                                                             */
492/******************************************************************************/
493/*                                                                            */
494/*  integer variable(nb) ----------->                                         */
495/*                                                                            */
496/*          INTEGER, DIMENSION(1:nb)         :: variable                      */
497/*                                                                            */
498/******************************************************************************/
499void writesub_loopdeclaration_scalar (listvar * deb_common, FILE *fileout)
500{
501  listvar *newvar;
502  variable *v;
503  char ligne[LONG_4C];
504
505  tofich (fileout, "",1);
506  newvar = deb_common;
507  while (newvar)
508  {
509     if ( newvar->var->v_nbdim == 0 &&
510          !strcasecmp(newvar->var->v_subroutinename,subroutinename)  &&
511           newvar->var->v_allocatable == 0                           &&
512           newvar->var->v_pointerdeclare == 0
513         )
514     {
515        v = newvar->var;
516
517        WriteBeginDeclaration(v,ligne);
518        WriteScalarDeclaration(v,ligne);
519        tofich (fileout, ligne,1);
520     }
521     newvar = newvar->suiv;
522  }
523  Save_Length(ligne,45);
524}
525
526/******************************************************************************/
527/*                       writesub_loopdeclaration_tab                         */
528/******************************************************************************/
529/* This subroutine is used to write the declaration part of subloop           */
530/*    subroutines                                                             */
531/******************************************************************************/
532/*                                                                            */
533/*  integer variable(nb) ----------->                                         */
534/*                                                                            */
535/*          INTEGER, DIMENSION(1:nb)         :: variable                      */
536/*                                                                            */
537/******************************************************************************/
538void writesub_loopdeclaration_tab (listvar * deb_common, FILE *fileout)
539{
540  listvar *newvar;
541  variable *v;
542  char ligne[LONG_4C];
543  int changeval;
544
545  tofich (fileout, "",1);
546  newvar = deb_common;
547  while (newvar)
548  {
549     if ( newvar->var->v_nbdim != 0                                 &&
550          !strcasecmp(newvar->var->v_subroutinename,subroutinename) &&
551          newvar->var->v_allocatable == 0                           &&
552          newvar->var->v_pointerdeclare == 0
553        )
554     {
555        changeval = 0;
556        v = newvar->var;
557        if ( v->v_allocatable == 1 )
558        {
559           changeval = 1;
560           v->v_allocatable = 0;
561        }
562        WriteBeginDeclaration(v,ligne);
563        WriteTableDeclaration(v,ligne,1);
564        tofich (fileout, ligne,1);
565        if ( changeval == 1 ) v->v_allocatable = 1;
566     }
567     newvar = newvar->suiv;
568  }
569  Save_Length(ligne,45);
570}
Note: See TracBrowser for help on using the repository browser.