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.
UtilFortran.c in trunk/AGRIF/LIB – NEMO

source: trunk/AGRIF/LIB/UtilFortran.c @ 396

Last change on this file since 396 was 396, checked in by opalod, 18 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.2 KB
Line 
1/******************************************************************************/
2/*                                                                            */
3/*     CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran)       */
4/*                                                                            */
5/*     Copyright (C) 2005 Laurent Debreu (Laurent.Debreu@imag.fr)             */
6/*                        Cyril Mazauric (Cyril.Mazauric@imag.fr)             */
7/*                                                                            */
8/*     This program is free software; you can redistribute it and/or modify   */
9/*    it                                                                      */
10/*                                                                            */
11/*    This program is distributed in the hope that it will be useful,         */
12/*     but WITHOUT ANY WARRANTY; without even the implied warranty of         */
13/*     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the          */
14/*    GNU General Public License for more details.                            */
15/*                                                                            */
16/******************************************************************************/
17#include <stdio.h>
18#include <stdlib.h>
19#include <string.h>
20#include "decl.h"
21
22/******************************************************************************/
23/*                            initdimprob                                     */
24/******************************************************************************/
25/* This subroutine is used to initialized grid dimension variable             */
26/******************************************************************************/
27/*                                                                            */
28/*                                                                            */
29/*                                                                            */
30/******************************************************************************/
31void initdimprob(int dimprobmod, char * nx, char * ny,char* nz)
32{
33  dimprob = dimprobmod;
34
35  strcpy(nbmaillesX,nx);
36  strcpy(nbmaillesY,ny);
37  strcpy(nbmaillesZ,nz);
38}
39
40/******************************************************************************/
41/*                      Variableshouldberemove                                */
42/******************************************************************************/
43/* Firstpass 0                                                                */
44/******************************************************************************/
45/*                                                                            */
46/*               Agrif_<toto>(variable) ====>     Agrif_<toto>(variable)      */
47/*                                                                            */
48/******************************************************************************/
49int Variableshouldberemove(char *nom)
50{
51
52   int remove;
53   
54   remove = 0 ; 
55   
56   if ( remove == 0 && !strcasecmp(nom,"RESHAPE") ) remove = 1 ; 
57   if ( remove == 0 && AGRIF_n_Agrif_in_Tok_NAME(nom) == 1 ) remove = 1 ; 
58
59   return remove;   
60}
61
62/******************************************************************************/
63/*                          variableisglobal                                  */
64/******************************************************************************/
65/* This subroutine is to know if a variable is global                         */
66/******************************************************************************/
67int variableisglobal(listvar *curvar, listvar *listin)
68{
69  int Globalite;
70  listvar *newvar;
71
72
73  Globalite = 0;
74  newvar = listin;
75  while ( newvar && Globalite == 0 )
76  {
77     if ( !strcasecmp(newvar->var->nomvar,curvar->var->nomvar) )
78     {
79        Globalite = 1;
80        /* Now we should give the definition of the variable in the           */
81        /* table listvarindoloop                                              */
82        strcpy(curvar->var->typevar,newvar->var->typevar);
83        strcpy(curvar->var->dimchar,newvar->var->dimchar);
84        curvar->var->nbdim = newvar->var->nbdim;
85        curvar->var->dimensiongiven = newvar->var->dimensiongiven;
86        curvar->var->typegiven = newvar->var->typegiven;
87        curvar->var->allocatable = newvar->var->allocatable;
88        curvar->var->pointerdeclare = newvar->var->pointerdeclare;
89        curvar->var->indicetabvars = newvar->var->indicetabvars;
90        strcpy(curvar->var->precision,newvar->var->precision);
91        strcpy(curvar->var->readedlistdimension,
92                                              newvar->var->readedlistdimension);
93     }
94     else
95     {
96         newvar = newvar->suiv;
97     }
98  }
99
100  return Globalite ;
101}
102
103/******************************************************************************/
104/*                     variableisparameterglobal                              */
105/******************************************************************************/
106/* This subroutine is to know if a variable is global                         */
107/******************************************************************************/
108int variableisparameterglobal(listvar *curvar, listparameter *listin)
109{
110  int Globalite;
111  listparameter *newvar;
112
113  Globalite = 0;
114  newvar = listin;
115  while ( newvar && Globalite == 0 )
116  {
117     if ( !strcasecmp(newvar->name,curvar->var->nomvar) ) Globalite = 1;
118     else newvar = newvar->suiv;
119  }
120
121  return Globalite ;
122}
123
124
125/******************************************************************************/
126/*                 addi_1_addsubroutine_inst_back_alloc                       */
127/******************************************************************************/
128/* Firstpass 0                                                                */
129/* We should add subroutine of instanciation, back instaciation and           */
130/* allocation                                                                 */
131/* if moduleorcontains = 1 we are at the end module keyword                   */
132/* if moduleorcontains = 0 we are at the contains   keyword                   */
133/******************************************************************************/
134void addi_0_addsubroutine_inst_back_alloc(int moduleorcontains)
135{
136   char ligne[LONGNOM];
137   int Allocisempty;
138   listvar *newvar;
139   
140
141   if ( firstpass == 0)
142   {
143     /* It is necessary to know if this subroutine is not empty               */
144     Allocisempty = 0;
145     newvar = globliste;
146     while ( newvar && Allocisempty == 0 )
147     {
148        if ( !strcasecmp(newvar->var->modulename,curmodulename)) Allocisempty=1;
149        else newvar = newvar->suiv;
150     }
151     if ( Allocisempty == 1 )
152     {
153         while ( newvar &&
154                 !strcasecmp(newvar->var->modulename,curmodulename) &&
155                 Allocisempty == 1 )
156         {
157            if ( (newvar->var->nbdim !=0          &&
158                  newvar->var->allocatable != 1 ) ||
159                 (newvar->var->nbdim == 0         &&
160                  strcmp(newvar->var->initialvalue,"")) ) Allocisempty = 0;
161            else newvar = newvar->suiv;
162         }
163     }
164     if ( Allocisempty == 0 )
165     {
166      if ( MOD_n_InstanceInModule() == 1)
167      {
168         /* we should remove end module <name>                                */
169         if ( moduleorcontains == 1 )
170         {
171            RemoveWordCUR(fortranout,(long)(-strlen(curmodulename)-12),
172                                          strlen(curmodulename)+11);
173         }
174         /* we should remove contains                                         */
175         if ( moduleorcontains == 0 )
176         {
177            RemoveWordCUR(fortranout,(long)(-8),8);
178         }
179         strcpy (ligne, "\n      PUBLIC Alloc_agrif_");
180         strcat (ligne, curmodulename);
181         strcat (ligne, "\n");
182         fprintf(fortranout,ligne);
183      }
184      if (MOD_n_InstanceInModule() == 1)
185      {     
186         fprintf(fortranout,"\n      contains\n"); 
187         strcpy (ligne, "\n#include \"alloc_agrif_");
188         strcat (ligne, curmodulename);
189         strcat (ligne, ".h\"\n");
190         fprintf(fortranout,ligne);
191         /* On reecrit la mot cle end module qui a ete efface du fichier      */
192         /*    d'origine                                                      */
193         if ( moduleorcontains == 1 ) fprintf(fortranout,"\n      end module %s"
194                                                                ,curmodulename);
195      }
196     }
197   }
198}
199
200
201/******************************************************************************/
202/*                          OPTI_0_IsTabvarsUseInArgument                     */
203/******************************************************************************/
204/* Firstpass 1                                                                */
205/******************************************************************************/
206/*                                                                            */
207/******************************************************************************/
208int OPTI_0_IsTabvarsUseInArgument()
209{
210   int out;
211   int doloopout;
212   listvar *parcours;   
213
214   out=1;
215 
216   if ( listvarindoloop )
217   {
218      doloopout = 0;
219      parcours = listvarindoloop;
220      while ( parcours && doloopout == 0 )   
221      {
222         if ( !strcasecmp(parcours->var->modulename,subroutinename) ) 
223                                                                  doloopout = 1;
224         else parcours = parcours->suiv;
225      }
226      if (  doloopout == 0 ) out = 0;
227      else out = 1 ;
228   }
229   else out = 0;
230
231   return out;
232}
233
234
235/******************************************************************************/
236/*                        ImplicitNoneInSubroutine                            */
237/******************************************************************************/
238/* Firstpass 0                                                                */
239/******************************************************************************/
240/*                                                                            */
241/******************************************************************************/
242int ImplicitNoneInSubroutine()
243{
244  listname *parcours;
245  int out;
246
247  parcours= listimplicitnone;
248  out = 0 ;
249  while ( parcours && out == 0 )
250  {
251     if ( !strcasecmp(parcours->name,subroutinename) ) out = 1;
252     else parcours = parcours->suiv;
253 
254  }
255  return out;
256}
257
258/******************************************************************************/
259/*                          OPTI_0_varispointer                               */
260/******************************************************************************/
261/* Firstpass 0                                                                */
262/******************************************************************************/
263/*                                                                            */
264/******************************************************************************/
265int OPTI_0_varispointer(char *ident)
266{
267   listvar *newvar;
268   int out;
269
270   out =0;
271   if (firstpass == 0 )
272   {
273      newvar = globalvarofusefile;
274      while ( newvar && out == 0 )
275      {
276         if ( !strcmp(ident,newvar->var->nomvar) && 
277              newvar->var->pointerdeclare == 1 )  out = 1;
278         else newvar = newvar->suiv;
279      }
280   }
281   return out;
282}
Note: See TracBrowser for help on using the repository browser.