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.
toamr.c in tags/nemo_v3_2/nemo_v3_2/AGRIF/LIB – NEMO

source: tags/nemo_v3_2/nemo_v3_2/AGRIF/LIB/toamr.c @ 1878

Last change on this file since 1878 was 1878, checked in by flavoni, 14 years ago

initial test for nemogcm

  • Property svn:eol-style set to native
File size: 49.6 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 <stdlib.h>
36#include <stdio.h>
37#include <string.h>
38#include "decl.h"
39char lvargridname[LONG_4C];
40char lvargridname2[LONG_4C];
41
42
43/******************************************************************************/
44/*                       variablenameroottabvars                              */
45/******************************************************************************/
46/* This subroutine is used to create the string                               */
47/******************************************************************************/
48/*                                                                            */
49/*  ----------->  Agrif_Mygrid % tabvars (i) % var                            */
50/*                                                                            */
51/******************************************************************************/
52char *variablenameroottabvars (variable * var)
53{
54  char *ligne;
55
56  ligne = (char *) malloc (LONG_C * sizeof (char));
57  sprintf (ligne, "Agrif_Mygrid %% tabvars(%d) %% var ", var->v_indicetabvars);
58  return ligne;
59}
60
61
62/******************************************************************************/
63/*                        variablenametabvars                                 */
64/******************************************************************************/
65/* This subroutine is used to create the string                               */
66/******************************************************************************/
67/*                                                                            */
68/*  if iorindice = 0 ---------->  Agrif_Gr % tabvars (i) % var                */
69/*                                                                            */
70/*  if iorindice = 1 ---------->  Agrif_Gr % tabvars (12) % var               */
71/*                                                                            */
72/******************************************************************************/
73char *variablenametabvars (variable * var, int iorindice)
74{
75  char *ligne;
76
77  ligne = (char *) malloc (LONG_C * sizeof (char));
78  if ( iorindice == 0 ) sprintf (ligne, " Agrif_Gr %% tabvars(%d)%% var",
79                                 var->v_indicetabvars);
80  else sprintf (ligne, " Agrif_Gr %% tabvars(i)%% var");
81  return ligne;
82}
83
84/******************************************************************************/
85/*                        variablecurgridtabvars                              */
86/******************************************************************************/
87/* This subroutine is used to create the string                               */
88/******************************************************************************/
89/*                                                                            */
90/*  ----------->  Agrif_Curgrid % tabvars (i) % var                           */
91/*                                                                            */
92/******************************************************************************/
93char *variablecurgridtabvars (variable * var,int ParentOrCurgrid)
94{
95  char *ligne;
96
97  ligne = (char *) malloc (LONG_C * sizeof (char));
98  if ( ParentOrCurgrid == 0 ) sprintf (ligne, " Agrif_tabvars(%d) %% var",
99                              var->v_indicetabvars);
100  else if ( ParentOrCurgrid == 1 ) sprintf (ligne,
101                              " Agrif_tabvars(%d) %% parent_var %% var",
102                               var->v_indicetabvars);
103  else if ( ParentOrCurgrid == 2 ) sprintf (ligne,
104                              " Agrif_Mygrid %% tabvars(%d) %% var",
105                               var->v_indicetabvars);
106  else if ( ParentOrCurgrid == 3 ) sprintf (ligne,
107                              " Agrif_Curgrid %% tabvars(%d) %% var",
108                               var->v_indicetabvars);
109  else sprintf (ligne, " AGRIF_Mygrid %% tabvars(%d) %% var",
110                               var->v_indicetabvars);
111  return ligne;
112}
113
114void WARNING_CharSize(variable *var)
115{
116   if ( var->v_nbdim == 0 )
117   {
118      if ( convert2int(var->v_dimchar) > 2050 )
119      {
120         printf("WARNING : The dimension of the character  %s   \n",
121                                                              var->v_nomvar);
122         printf("   is upper than 2050. You must change         \n");
123         printf("   the dimension of carray0                    \n");
124         printf("   in the file AGRIF/AGRIF_FILES/modtypes.F    \n");
125         printf("   line 247. Replace 300 with %d.              \n",
126                                            convert2int(var->v_dimchar)+100);
127      }
128      Save_Length_int(convert2int(var->v_dimchar),1);
129   }
130   else if ( var->v_nbdim == 1 )
131   {
132      if ( convert2int(var->v_dimchar) > 300 )
133      {
134         printf("WARNING : The dimension of the character  %s   \n",
135                                                              var->v_nomvar);
136         printf("   is upper than 300. You must change          \n");
137         printf("   the dimension of carray1                    \n");
138         printf("   in the file AGRIF/AGRIF_FILES/modtypes.F    \n");
139         printf("   line 247. Replace 300 with %d.              \n",
140                                            convert2int(var->v_dimchar)+100);
141      }
142      Save_Length_int(convert2int(var->v_dimchar),2);
143   }
144   else if ( var->v_nbdim == 2 )
145   {
146      if ( convert2int(var->v_dimchar) > 300 )
147      {
148         printf("WARNING : The dimension of the character  %s   \n",
149                                                              var->v_nomvar);
150         printf("   is upper than 300. You must change          \n");
151         printf("   the dimension of carray2                    \n");
152         printf("   in the file AGRIF/AGRIF_FILES/modtypes.F    \n");
153         printf("   line 247. Replace 300 with %d.              \n",
154                                            convert2int(var->v_dimchar)+100);
155      }
156      Save_Length_int(convert2int(var->v_dimchar),3);
157   }
158   else if ( var->v_nbdim == 3 )
159   {
160      if ( convert2int(var->v_dimchar) > 300 )
161      {
162         printf("WARNING : The dimension of the character  %s   \n",
163                                                              var->v_nomvar);
164         printf("   is upper than 300. You must change          \n");
165         printf("   the dimension of carray3                    \n");
166         printf("   in the file AGRIF/AGRIF_FILES/modtypes.F    \n");
167         printf("   line 247. Replace 300 with %d.              \n",
168                                            convert2int(var->v_dimchar)+100);
169      }
170      Save_Length_int(convert2int(var->v_dimchar),4);
171   }
172}
173/******************************************************************************/
174/*                           vargridnametabvars                               */
175/******************************************************************************/
176/* This subroutine is used to create the string                               */
177/******************************************************************************/
178/*                                                                            */
179/*  if iorindice == 0 ----------->  Agrif_Gr % tabvars (i) % var % array1     */
180/*                                                                            */
181/*  if iorindice == 1 ----------->  Agrif_Gr % tabvars (12) % var % array1    */
182/*                                                                            */
183/******************************************************************************/
184char *vargridnametabvars (variable * var,int iorindice)
185{
186  char *tmp;
187  char tmp1[LONG_C];
188
189  tmp = variablenametabvars (var,iorindice);
190  strcpy(tmp1,tmp);
191  if ( todebugfree == 1 ) free(tmp);
192
193  sprintf (lvargridname, "%s", tmp1);
194  if (!strcasecmp (var->v_typevar, "REAL"))
195    {
196      if ( !strcasecmp(var->v_nameinttypename,"8") )
197                           sprintf (lvargridname2, "%% darray%d", var->v_nbdim);
198      else if ( !strcasecmp(var->v_nameinttypename,"4") )
199                           sprintf (lvargridname2, "%% sarray%d", var->v_nbdim);
200      else sprintf (lvargridname2, "%% array%d", var->v_nbdim);
201    }
202  else if (!strcasecmp (var->v_typevar, "INTEGER"))
203    {
204      sprintf (lvargridname2, "%% iarray%d", var->v_nbdim);
205    }
206  else if (!strcasecmp (var->v_typevar, "LOGICAL"))
207    {
208      sprintf (lvargridname2, "%% larray%d", var->v_nbdim);
209    }
210  else if (!strcasecmp (var->v_typevar, "CHARACTER"))
211    {
212      WARNING_CharSize(var);
213      sprintf (lvargridname2, "%% carray%d", var->v_nbdim);
214    }
215
216  strcat (lvargridname, lvargridname2);
217
218  Save_Length(lvargridname,42);
219  Save_Length(lvargridname2,42);
220  return lvargridname;
221}
222
223/******************************************************************************/
224/*                           vargridcurgridtabvars                            */
225/******************************************************************************/
226/* This subroutine is used to create the string                               */
227/******************************************************************************/
228/*                                                                            */
229/* if ParentOrCurgrid == 0 -->  Agrif_Curgrid % tabvars (i) % var % array1    */
230/*                                                                            */
231/* if ParentOrCurgrid == 1 -->  Agrif_tabvars (i) % parent_var %var % array1  */
232/*                                                                            */
233/* if ParentOrCurgrid == 2 -->  Agrif_Gr % tabvars (i) % var % array1         */
234/*                                                                            */
235/******************************************************************************/
236char *vargridcurgridtabvars (variable * var,int ParentOrCurgrid)
237{
238  char *tmp;
239  char tmp1[LONG_C];
240
241 if (!strcasecmp(var->v_typevar,"type"))
242  {
243  strcpy(lvargridname2,"");
244  sprintf(lvargridname,"Agrif_%s_var(Agrif_Curgrid%%fixedrank)%%%s",var->v_modulename,var->v_nomvar);
245  }
246  else
247  {
248  tmp = variablecurgridtabvars (var,ParentOrCurgrid);
249  strcpy(tmp1,tmp);
250  if ( todebugfree == 1 ) free(tmp);
251
252  sprintf (lvargridname, "%s", tmp1);
253  if (!strcasecmp (var->v_typevar, "REAL"))
254    {
255      if ( !strcasecmp(var->v_nameinttypename,"8") )
256                           sprintf (lvargridname2, "%% darray%d", var->v_nbdim);
257      else if ( !strcasecmp(var->v_nameinttypename,"4") )
258                           sprintf (lvargridname2, "%% sarray%d", var->v_nbdim);
259      else sprintf (lvargridname2, "%% array%d", var->v_nbdim);
260    }
261  else if (!strcasecmp (var->v_typevar, "INTEGER"))
262    {
263      sprintf (lvargridname2, "%% iarray%d", var->v_nbdim);
264    }
265  else if (!strcasecmp (var->v_typevar, "LOGICAL"))
266    {
267      sprintf (lvargridname2, "%% larray%d", var->v_nbdim);
268    }
269  else if (!strcasecmp (var->v_typevar, "CHARACTER"))
270    {
271      WARNING_CharSize(var);
272      sprintf (lvargridname2, "%% carray%d", var->v_nbdim);
273    }
274  }
275
276  strcat (lvargridname, lvargridname2);
277
278  Save_Length(lvargridname,42);
279  Save_Length(lvargridname2,42);
280  return lvargridname;
281}
282
283/******************************************************************************/
284/*                  vargridcurgridtabvarswithoutAgrif_Gr                      */
285/******************************************************************************/
286/* This subroutine is used to create the string                               */
287/******************************************************************************/
288/*                                                                            */
289/******************************************************************************/
290char *vargridcurgridtabvarswithoutAgrif_Gr (variable * var)
291{
292
293  sprintf (lvargridname, "(%d) %% var", var->v_indicetabvars);
294
295  if (!strcasecmp (var->v_typevar, "REAL"))
296    {
297      if ( !strcasecmp(var->v_nameinttypename,"8") )
298                           sprintf (lvargridname2, "%% darray%d", var->v_nbdim);
299      else if ( !strcasecmp(var->v_nameinttypename,"4") )
300                           sprintf (lvargridname2, "%% sarray%d", var->v_nbdim);
301      else sprintf (lvargridname2, "%% array%d", var->v_nbdim);
302    }
303  else if (!strcasecmp (var->v_typevar, "INTEGER"))
304    {
305      sprintf (lvargridname2, "%% iarray%d", var->v_nbdim);
306    }
307  else if (!strcasecmp (var->v_typevar, "LOGICAL"))
308    {
309      sprintf (lvargridname2, "%% larray%d", var->v_nbdim);
310    }
311  else if (!strcasecmp (var->v_typevar, "CHARACTER"))
312    {
313      WARNING_CharSize(var);
314      sprintf (lvargridname2, "%% carray%d", var->v_nbdim);
315    }
316
317  strcat (lvargridname, lvargridname2);
318
319  Save_Length(lvargridname,42);
320  Save_Length(lvargridname2,42);
321  return lvargridname;
322}
323
324/******************************************************************************/
325/*                               vargridparam                                 */
326/******************************************************************************/
327/* This subroutine is used to create the string which contains                */
328/* dimension list                                                             */
329/******************************************************************************/
330/*                                                                            */
331/*  DIMENSION(jpi,0:jpj) ----------->"1:jpi,0:jpj"                            */
332/*                                                                            */
333/******************************************************************************/
334char *vargridparam (variable * v, int whichone)
335{
336  typedim dim;
337  listdim *newdim;
338  char newname[LONG_4C];
339
340  newdim = v->v_dimension;
341  if (!newdim) return "";
342
343  strcpy (tmpvargridname, "(");
344  while (newdim)
345  {
346     dim = newdim->dim;
347
348     strcpy(newname,"");
349     strcpy(newname,
350            ChangeTheInitalvaluebyTabvarsName(dim.first,List_Global_Var,
351                                                                     whichone));
352                                                                     
353        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,
354                       List_Common_Var,whichone));
355
356        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,
357                       List_ModuleUsed_Var,whichone));
358
359     strcat (tmpvargridname, newname);
360     strcat (tmpvargridname, " : ");
361
362     strcpy(newname,"");
363     strcpy(newname,ChangeTheInitalvaluebyTabvarsName
364                        (dim.last,List_Global_Var,whichone));
365                       
366        strcpy(newname,ChangeTheInitalvaluebyTabvarsName
367                       (newname, List_Common_Var,whichone));   
368                       
369        strcpy(newname,ChangeTheInitalvaluebyTabvarsName
370                       (newname, List_ModuleUsed_Var,whichone));                                           
371                       
372     Save_Length(tmpvargridname,46);
373     strcat (tmpvargridname, newname);
374     newdim = newdim->suiv;
375     if (newdim) strcat (tmpvargridname, ",");
376  }
377  strcat (tmpvargridname, ")");
378  strcat (tmpvargridname, "\0");
379  Save_Length(tmpvargridname,40);
380  return tmpvargridname;
381}
382
383/******************************************************************************/
384/*                        write_probdimagrif_file                             */
385/******************************************************************************/
386/* This subroutine is used to create the file probdim_agrif.h                 */
387/******************************************************************************/
388/*                                                                            */
389/*               probdim_agrif.h                                              */
390/*                                                                            */
391/*               Agrif_probdim = <number>                                     */
392/*                                                                            */
393/******************************************************************************/
394void write_probdimagrif_file()
395{
396  FILE *probdim;
397  char ligne[LONG_C];
398
399  probdim = associate("probdim_agrif.h");
400  sprintf (ligne, "Agrif_Probdim = %d", dimprob);
401  tofich (probdim, ligne,1);
402  fclose (probdim);
403}
404
405/******************************************************************************/
406/*                             write_keysagrif_file                           */
407/******************************************************************************/
408/* This subroutine is used to create the file keys_agrif.h                    */
409/******************************************************************************/
410/*                                                                            */
411/*               keys_agrif.h                                                 */
412/*                                                                            */
413/*               AGRIF_USE_FIXED_GRIDS = 0                                    */
414/*               AGRIF_USE_ONLY_FIXED_GRIDS = 0                               */
415/*               AGRIF_USE_(ONLY)_FIXED_GRIDS = 1                             */
416/*                                                                            */
417/******************************************************************************/
418void write_keysagrif_file()
419{
420  FILE *keys;
421
422  keys = associate ("keys_agrif.h");
423  fprintf(keys,"      AGRIF_USE_FIXED_GRIDS = 0\n");
424  fprintf(keys,"      AGRIF_USE_ONLY_FIXED_GRIDS = 0\n");
425  if (fixedgrids     == 1) fprintf(keys,"      AGRIF_USE_FIXED_GRIDS = 1\n");
426  if (onlyfixedgrids == 1)
427                         fprintf(keys,"      AGRIF_USE_ONLY_FIXED_GRIDS = 1\n");
428
429  fclose(keys);
430}
431
432/******************************************************************************/
433/*                      write_modtypeagrif_file                               */
434/******************************************************************************/
435/* This subroutine is used to create the file typedata                        */
436/******************************************************************************/
437/*                                                                            */
438/*               modtype_agrif.h                                              */
439/*                                                                            */
440/*               Agrif_NbVariables =                                          */
441/*                                                                            */
442/******************************************************************************/
443void write_modtypeagrif_file()
444{
445  char ligne[LONG_C];
446  FILE *typedata;
447
448  typedata = associate ("modtype_agrif.h");
449  /* AGRIF_NbVariables : number of variables                                  */
450  sprintf (ligne, "AGRIF_NbVariables = %d",indicemaxtabvars);
451  tofich(typedata,ligne,1);
452  fclose (typedata);
453}
454
455/******************************************************************************/
456/*                   write_createvarnameagrif_file                            */
457/******************************************************************************/
458/* This subroutine is used to create the file  createvarname                  */
459/******************************************************************************/
460/*                                                                            */
461/*    Agrif_Gr % tabvars (i) % var % namevar = "variable"                     */
462/*                                                                            */
463/******************************************************************************/
464void write_createvarnameagrif_file(variable *v,FILE *createvarname,
465                                                       int *InitEmpty)
466{
467  char ligne[LONG_C];
468  char *tmp;
469  char temp1[LONG_C];
470
471  tmp =  variablenametabvars(v,0);
472  strcpy (temp1, tmp);
473  if ( todebugfree == 1 ) free(tmp);
474
475  *InitEmpty = 0 ;
476  sprintf(ligne, "%s %% namevar = \"%s\"",temp1,v->v_nomvar);
477  tofich(createvarname,ligne,1);
478}
479
480/******************************************************************************/
481/*                        write_Setnumberofcells_file                         */
482/******************************************************************************/
483/* This subroutine is used to create the file  setnumberofcells               */
484/******************************************************************************/
485/*                                                                            */
486/*              Agrif_Gr % n(i) = nbmailles                                   */
487/*                                                                            */
488/******************************************************************************/
489void write_Setnumberofcells_file(char *name)
490{
491  char ligne[LONG_C];
492  FILE *setnumberofcells;
493
494  if ( IndicenbmaillesX != 0 )
495  {
496  setnumberofcells=associate(name);
497
498  if (onlyfixedgrids != 1 )
499  {
500  sprintf (ligne,
501           "Agrif_Gr %% nb(1) = Agrif_Gr %% tabvars(%d) %% var %% iarray0",
502           IndicenbmaillesX);
503  }
504  else
505  {
506  sprintf (ligne,
507           "Agrif_Gr %% nb(1) = Agrif_Curgrid %% tabvars(%d) %% var %% iarray0",
508           IndicenbmaillesX);
509  }
510  tofich (setnumberofcells, ligne,1);
511  if (dimprob > 1)
512  {
513     if (onlyfixedgrids != 1 )
514     {
515     sprintf (ligne,
516           "Agrif_Gr %% nb(2) = Agrif_Gr %% tabvars(%d) %% var %% iarray0",
517           IndicenbmaillesY);
518     }
519     else
520     {
521     sprintf (ligne,
522           "Agrif_Gr %% nb(2) = Agrif_Curgrid %% tabvars(%d) %% var %% iarray0",
523           IndicenbmaillesY);
524     }
525
526     tofich (setnumberofcells, ligne,1);
527  }
528  if (dimprob > 2)
529  {
530     if (onlyfixedgrids != 1 )
531     {
532     sprintf (ligne,
533           "Agrif_Gr %% nb(3) = Agrif_Gr %% tabvars(%d) %% var %% iarray0",
534           IndicenbmaillesZ);
535     }
536     else
537     {
538     sprintf (ligne,
539           "Agrif_Gr %% nb(3) = Agrif_Curgrid %% tabvars(%d) %% var %% iarray0",
540           IndicenbmaillesZ);
541     }
542     tofich (setnumberofcells, ligne,1);
543  }
544
545  fclose (setnumberofcells);
546  }
547}
548
549/******************************************************************************/
550/*                       write_Getnumberofcells_file                          */
551/******************************************************************************/
552/* This subroutine is used to create the file  getnumberofcells               */
553/******************************************************************************/
554/*                                                                            */
555/*              nbmailles = Agrif_Gr % n(i)                                   */
556/*                                                                            */
557/******************************************************************************/
558void write_Getnumberofcells_file(char *name)
559{
560  char ligne[LONG_C];
561  FILE *getnumberofcells;
562
563  if ( IndicenbmaillesX != 0 )
564  {
565  getnumberofcells=associate(name);
566  sprintf (ligne,
567           "Agrif_Curgrid %% tabvars(%d) %% var %% iarray0 = Agrif_Gr %% nb(1)",
568           IndicenbmaillesX);
569  tofich (getnumberofcells, ligne,1);
570  if (dimprob > 1)
571    {
572      sprintf (ligne,
573           "Agrif_Curgrid %% tabvars(%d) %% var %% iarray0 = Agrif_Gr %% nb(2)",
574           IndicenbmaillesY);
575      tofich (getnumberofcells, ligne,1);
576    }
577  if (dimprob > 2)
578    {
579      sprintf (ligne,
580           "Agrif_Curgrid %% tabvars(%d) %% var %% iarray0 = Agrif_Gr %% nb(3)",
581           IndicenbmaillesZ);
582      tofich (getnumberofcells, ligne,1);
583    }
584  fclose (getnumberofcells);
585  }
586}
587
588
589/******************************************************************************/
590/*                      write_initialisationsagrif_file                       */
591/******************************************************************************/
592/* This subroutine is used to create the file initproc                        */
593/******************************************************************************/
594/*                                                                            */
595/*              ! variable                                                    */
596/*              Agrif_Gr % tabvars(i) % var % nbdim = 1                       */
597/*                                                                            */
598/******************************************************************************/
599void write_initialisationsagrif_file(variable *v,FILE *initproc,
600                                     int *VarnameEmpty)
601{
602  char ligne[LONG_C];
603  char temp1[LONG_C];
604  char *tmp;
605
606  tmp = variablenameroottabvars (v);
607  strcpy (temp1, tmp);
608  if ( todebugfree == 1 ) free(tmp);
609
610  if ( v->v_nbdim != 0 )
611  {
612     *VarnameEmpty = 0 ;
613     sprintf (ligne, "%s %% nbdim = %d", temp1, v->v_nbdim);
614     tofich (initproc, ligne,1);
615  }
616}
617
618
619void Write_Alloc_Agrif_Files()
620{
621   listnom *parcours;
622   FILE *alloccalls;
623   FILE *AllocUSE;
624
625   AllocUSE= associate("include_use_Alloc_agrif.h");
626   alloccalls = associate("allocations_calls_agrif.h");
627
628   parcours = List_Subroutine_For_Alloc;
629   while ( parcours )
630   {
631      fprintf(AllocUSE,"      USE %s\n", parcours -> o_nom );
632      fprintf (alloccalls,"      Call Alloc_agrif_%s(Agrif_Gr)\n",
633                                                            parcours -> o_nom );
634      parcours = parcours -> suiv;
635   }
636
637   fclose (AllocUSE);
638   fclose (alloccalls);
639}
640
641int IndiceInlist(int indic, listindice *listin)
642{
643   listindice *parcoursindic;
644   int out;
645
646   out = 0 ;
647
648   parcoursindic = listin;
649   while ( parcoursindic && out == 0 )
650   {
651      if ( parcoursindic->i_indice == indic ) out = 1;
652      else parcoursindic = parcoursindic -> suiv;
653   }
654
655   return out;
656}
657void write_allocation_Common_0()
658{
659   listnom *parcours_nom;
660   listnom *neededparameter;
661   listvar *parcours;
662   listvar *parcoursprec;
663   listvar *parcours1;
664   FILE *allocationagrif;
665   FILE *paramtoamr;
666   char ligne[LONGNOM];
667   variable *v;
668   int IndiceMax;
669   int IndiceMin;
670   int compteur;
671   int out;
672   int indiceprec;
673   int ValeurMax;
674   char initialvalue[LONG_4C];
675   listindice *list_indic;
676   listindice *parcoursindic;
677   int i;
678
679   parcoursprec = (listvar *)NULL;
680   parcours_nom = List_NameOfCommon;
681   ValeurMax = 2;
682   while ( parcours_nom  )
683   {
684      /*                                                                      */
685      if ( parcours_nom->o_val == 1 )
686      {
687         /* Open the file to create the Alloc_agrif subroutine                */
688         sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom);
689         allocationagrif = associate (ligne);
690         /*                                                                   */
691         fprintf(allocationagrif,"#include \"Param_toamr_%s.h\" \n",
692                                                           parcours_nom->o_nom);
693         /*                                                                   */
694         sprintf(ligne,"Param_toamr_%s.h",parcours_nom->o_nom);
695         paramtoamr = associate (ligne);
696         neededparameter = (listnom * )NULL;
697         /*                                                                   */
698         list_indic = (listindice *)NULL;
699         /*                                                                   */
700         shouldincludempif = 1 ;
701         parcours = List_Common_Var;
702         while ( parcours )
703         {
704            if ( !strcasecmp(parcours->var->v_commonname,parcours_nom->o_nom) &&
705                  IndiceInlist(parcours->var->v_indicetabvars,list_indic) == 0
706               )
707            {
708               /***************************************************************/
709               /***************************************************************/
710               /***************************************************************/
711               v = parcours->var;
712               IndiceMax = 0;
713               IndiceMin = indicemaxtabvars;
714  /* body of the file                                                         */
715  if ( !strcasecmp(v->v_commoninfile,mainfile) )
716  {
717     if (onlyfixedgrids != 1 && v->v_nbdim!=0)
718     {
719        strcpy (ligne, "If (.not. associated(");
720        strcat (ligne, vargridnametabvars(v,0));
721        strcat (ligne, "))                       then");
722        Save_Length(ligne,48);
723        tofich (allocationagrif, ligne,1);
724     }
725     if ( v->v_allocatable != 1 && ( v->v_dimsempty != 1) )
726     {
727        /*                ALLOCATION                                          */
728        if ( v->v_dimension != 0  )
729        {
730           if ( v->v_indicetabvars < IndiceMin ||
731                v->v_indicetabvars > IndiceMax )
732           {
733              parcours1 = parcours;
734              compteur = -1;
735              out = 0;
736              indiceprec = parcours->var->v_indicetabvars -1 ;
737              while ( parcours1 && out == 0 &&
738                      !strcasecmp(  parcours->var->v_readedlistdimension,
739                                  parcours1->var->v_readedlistdimension) &&
740                      !strcasecmp(  parcours->var->v_typevar,
741                                  parcours1->var->v_typevar) &&
742                            ( parcours1->var->v_indicetabvars == indiceprec+1 )
743                     )
744              {
745
746               if ( !strcasecmp(parcours1->var->v_modulename,
747                                parcours_nom->o_nom) ||
748                    !strcasecmp(parcours1->var->v_commonname,
749                                parcours_nom->o_nom) )
750                 {
751                      compteur = compteur +1 ;
752                      indiceprec = parcours1->var->v_indicetabvars;
753                      parcoursprec = parcours1;
754                      parcours1 = parcours1->suiv;
755                 }
756                 else out = 1;
757              }
758
759              if ( compteur > ValeurMax )
760              {
761                 fprintf(allocationagrif,"      DO i = %d , %d\n",
762                                         parcours->var->v_indicetabvars,
763                                       parcours->var->v_indicetabvars+compteur);
764                 IndiceMin = parcours->var->v_indicetabvars;
765                 IndiceMax = parcours->var->v_indicetabvars+compteur;
766                 strcpy (ligne, "allocate ");
767                 strcat (ligne, "(");
768                 strcat (ligne, vargridnametabvars(v,1));
769                 strcat (ligne, vargridparam(v,0));
770                 strcat (ligne, ")");
771                 Save_Length(ligne,48);
772                 tofich (allocationagrif, ligne,1);
773                 fprintf(allocationagrif,"      end do\n");
774                 i=parcours->var->v_indicetabvars;
775                 do
776                 {
777                    parcoursindic =  (listindice *)malloc(sizeof(listindice));
778                    parcoursindic -> i_indice = i;
779                    parcoursindic -> suiv = list_indic;
780                    list_indic = parcoursindic;
781                    i = i + 1;
782                 } while ( i <= parcours->var->v_indicetabvars+compteur );
783                 parcours = parcoursprec;
784                 /*                                                           */
785              }
786              else
787              {
788                 strcpy (ligne, "allocate ");
789                 strcat (ligne, "(");
790                 strcat (ligne, vargridnametabvars(v,0));
791                 strcat (ligne, vargridparam(v,0));
792                 strcat (ligne, ")");
793                 Save_Length(ligne,48);
794                 tofich (allocationagrif, ligne,1);
795                 /*                                                           */
796                 parcoursindic =  (listindice *)malloc(sizeof(listindice));
797                 parcoursindic -> i_indice = parcours->var->v_indicetabvars;
798                 parcoursindic -> suiv = list_indic;
799                 list_indic = parcoursindic;
800              }
801                neededparameter = writedeclarationintoamr(List_Parameter_Var,
802                              paramtoamr,v,parcours_nom->o_nom,neededparameter,
803                                                               v->v_commonname);
804              /*                                                              */
805           }
806        } /* end of the allocation part                                       */
807        /*                INITIALISATION                                      */
808        if ( strcasecmp(v->v_initialvalue,"") )
809        {
810           strcpy (ligne, "");
811           strcat (ligne, vargridnametabvars(v,0));
812           /* We should modify the initialvalue in the case of variable has   */
813           /*    been defined with others variables                           */
814                     
815           strcpy(initialvalue,
816                  ChangeTheInitalvaluebyTabvarsName
817                                      (v->v_initialvalue,List_Global_Var,0));
818           if ( !strcasecmp(initialvalue,v->v_initialvalue) )
819           {
820              strcpy(initialvalue,"");
821              strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
822                                      (v->v_initialvalue,List_Common_Var,0));
823           }
824           if ( !strcasecmp(initialvalue,v->v_initialvalue) )
825           {
826              strcpy(initialvalue,"");
827              strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
828                                     (v->v_initialvalue,List_ModuleUsed_Var,0));
829           }
830           strcat (ligne," = ");
831           strcat (ligne,initialvalue);
832           /*                                                                 */
833           Save_Length(ligne,48);
834           tofich (allocationagrif, ligne,1);
835        }
836     }
837     if (onlyfixedgrids != 1 && v->v_nbdim!=0)
838     {
839        strcpy (ligne, "   End if");
840        tofich (allocationagrif, ligne,1);
841     }
842  }
843               /***************************************************************/
844               /***************************************************************/
845               /***************************************************************/
846            }
847            parcours = parcours -> suiv;
848         }
849         /* Close the file Alloc_agrif                                        */
850         fclose(allocationagrif);
851         fclose(paramtoamr);
852      }
853      /*                                                                      */
854      parcours_nom = parcours_nom -> suiv;
855   }
856
857}
858
859
860
861void write_allocation_Global_0()
862{
863   listnom *parcours_nom;
864   listvar *parcours;
865   listvar *parcoursprec;
866   listvar *parcours1;
867   FILE *allocationagrif;
868   char ligne[LONGNOM];
869   variable *v;
870   int IndiceMax;
871   int IndiceMin;
872   int compteur;
873   int out;
874   int indiceprec;
875   int ValeurMax;
876   char initialvalue[LONG_4C];
877   int typeiswritten ;
878
879   parcoursprec = (listvar *)NULL;
880   parcours_nom = List_NameOfModule;
881   ValeurMax = 2;
882   while ( parcours_nom  )
883   {
884      /*                                                                      */
885      if ( parcours_nom->o_val == 1 )
886      {
887         IndiceMax = 0;
888         IndiceMin = indicemaxtabvars;
889         /* Open the file to create the Alloc_agrif subroutine                */
890         sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom);
891         allocationagrif = associate (ligne);
892         /*                                                                   */
893         if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 )
894         {
895             /* add the call to initworkspace                                 */
896            tofich(allocationagrif,"if ( .NOT. Agrif_Root() ) then ",1);
897            fprintf(allocationagrif,"#include \"GetNumberofcells.h\" \n");
898            tofich(allocationagrif,"else ",1);
899            fprintf(allocationagrif,"#include \"SetNumberofcells.h\" \n");
900            tofich(allocationagrif,"endif ",1);
901            tofich(allocationagrif,"Call Agrif_InitWorkspace ",1);
902         }
903
904         typeiswritten = 0;
905
906         parcours = List_Global_Var;
907         while ( parcours )
908         {
909            if ( !strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom) &&
910                 parcours->var->v_VariableIsParameter == 0                  &&
911                 parcours->var->v_notgrid == 0                              &&
912                 !strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom)  )
913            {
914               /***************************************************************/
915               /***************************************************************/
916               /***************************************************************/
917               v = parcours->var;
918               IndiceMax = 0;
919               IndiceMin = indicemaxtabvars;
920  /* body of the file                                                         */
921  if ( !strcasecmp(v->v_commoninfile,mainfile) )
922  {
923     if (onlyfixedgrids != 1 && v->v_nbdim!=0)
924     {
925        strcpy (ligne, "If (.not. associated(");
926        strcat (ligne, vargridnametabvars(v,0));
927        strcat (ligne, "))                       then");
928        Save_Length(ligne,48);
929        tofich (allocationagrif, ligne,1);
930     }
931     if ( v->v_allocatable != 1 && ( v->v_dimsempty != 1) )
932     {
933        /*                ALLOCATION                                          */
934        if ( v->v_dimension != 0  )
935        {
936           if ( v->v_indicetabvars < IndiceMin ||
937                v->v_indicetabvars > IndiceMax )
938           {
939              parcours1 = parcours;
940              compteur = -1;
941              out = 0;
942              indiceprec = parcours->var->v_indicetabvars -1 ;
943              while ( parcours1 && out == 0 &&
944                      !strcasecmp(  parcours->var->v_readedlistdimension,
945                                  parcours1->var->v_readedlistdimension) &&
946                      !strcasecmp(  parcours->var->v_typevar,
947                                  parcours1->var->v_typevar) &&
948                             ( parcours1->var->v_indicetabvars == indiceprec+1 )
949                     )
950              {
951
952               if ( !strcasecmp(parcours1->var->v_modulename,
953                                parcours_nom->o_nom) ||
954                    !strcasecmp(parcours1->var->v_commonname,
955                                parcours_nom->o_nom) )
956                 {
957                      compteur = compteur +1 ;
958                      indiceprec = parcours1->var->v_indicetabvars;
959                      parcoursprec = parcours1;
960                      parcours1 = parcours1->suiv;
961                 }
962                 else out = 1;
963              }
964              if ( compteur > ValeurMax )
965              {
966                 fprintf(allocationagrif,"      DO i = %d , %d\n",
967                                          parcours->var->v_indicetabvars,
968                                       parcours->var->v_indicetabvars+compteur);
969                 IndiceMin = parcours->var->v_indicetabvars;
970                 IndiceMax = parcours->var->v_indicetabvars+compteur;
971                 strcpy (ligne, "allocate ");
972                 strcat (ligne, "(");
973                 strcat (ligne, vargridnametabvars(v,1));
974                 strcat (ligne, vargridparam(v,0));
975                 strcat (ligne, ")");
976                 Save_Length(ligne,48);
977                 tofich (allocationagrif, ligne,1);
978                 fprintf(allocationagrif,"      end do\n");
979                 parcours = parcoursprec;
980              }
981              else
982              {
983                 strcpy (ligne, "allocate ");
984                 strcat (ligne, "(");
985                 strcat (ligne, vargridnametabvars(v,0));
986                 strcat (ligne, vargridparam(v,0));
987                 strcat (ligne, ")");
988                 Save_Length(ligne,48);
989                 tofich (allocationagrif, ligne,1);
990              }
991           }
992        } /* end of the allocation part                                       */
993
994        /*                INITIALISATION                                      */
995        if ( strcasecmp(v->v_initialvalue,"") )
996        {
997           strcpy (ligne, "");
998           strcat (ligne, vargridnametabvars(v,0));
999           /* We should modify the initialvalue in the case of variable has   */
1000           /*    been defined with others variables                           */
1001
1002           strcpy(initialvalue,
1003                  ChangeTheInitalvaluebyTabvarsName
1004                                      (v->v_initialvalue,List_Global_Var,0));
1005           if ( !strcasecmp(initialvalue,v->v_initialvalue) )
1006           {
1007              strcpy(initialvalue,"");
1008              strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
1009                                      (v->v_initialvalue,List_Common_Var,0));
1010           }
1011           if ( !strcasecmp(initialvalue,v->v_initialvalue) )
1012           {
1013              strcpy(initialvalue,"");
1014              strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
1015                                     (v->v_initialvalue,List_ModuleUsed_Var,0));
1016           }
1017           strcat (ligne," = ");
1018           strcat (ligne,initialvalue);
1019           /*                                                                 */
1020           Save_Length(ligne,48);
1021           tofich (allocationagrif, ligne,1);
1022        }
1023     }
1024/* Case of structure types */
1025        if ((typeiswritten == 0) && !strcasecmp(v->v_typevar,"type"))
1026        {
1027        sprintf(ligne,"If (.Not.Allocated(Agrif_%s_var)) Then",v->v_modulename);
1028        tofich(allocationagrif, ligne, 1);
1029        sprintf(ligne,"Allocate(Agrif_%s_var(0:Agrif_NbMaxGrids))",v->v_modulename);
1030        tofich(allocationagrif, ligne, 1);
1031        strcpy(ligne,"End If");
1032        tofich(allocationagrif, ligne, 1);
1033        typeiswritten = 1;
1034        }
1035     if (onlyfixedgrids != 1 && v->v_nbdim!=0)
1036     {
1037        strcpy (ligne, "   End if");
1038        tofich (allocationagrif, ligne,1);
1039     }
1040  }
1041               /***************************************************************/
1042               /***************************************************************/
1043               /***************************************************************/
1044            }
1045            parcours = parcours -> suiv;
1046         }
1047         /*                                                                   */
1048         if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 )
1049         {
1050            /* add the call to initworkspace                                  */
1051            tofich(allocationagrif,"if ( .NOT. Agrif_Root() ) then ",1);
1052            fprintf(allocationagrif,"#include \"GetNumberofcells.h\" \n");
1053            tofich(allocationagrif,"else ",1);
1054            fprintf(allocationagrif,"#include \"SetNumberofcells.h\" \n");
1055            tofich(allocationagrif,"endif ",1);
1056            tofich(allocationagrif,"Call Agrif_InitWorkspace ",1);
1057         }
1058         /* Close the file Alloc_agrif                                        */
1059         fclose(allocationagrif);
1060      } /* end parcours_nom == 1                                              */
1061      /*                                                                      */
1062      parcours_nom = parcours_nom -> suiv;
1063   }
1064}
1065
1066/******************************************************************************/
1067/*                           creefichieramr                                   */
1068/******************************************************************************/
1069/* This subroutine is the main one to create AGRIF_INC files                  */
1070/******************************************************************************/
1071/*                                                                            */
1072/******************************************************************************/
1073void creefichieramr (char *NameTampon)
1074{
1075  listvar *newvar;
1076  variable *v;
1077  int erreur;
1078  char filefich[LONG_C];
1079  char ligne[LONG_C];
1080  int IndiceMax;
1081  int IndiceMin;
1082  int InitEmpty;
1083  int VarnameEmpty;
1084  int donotwrite;
1085
1086  FILE *initproc;
1087  FILE *initglobal;
1088  FILE *createvarname;
1089  FILE *createvarnameglobal;
1090
1091  if ( todebug == 1 ) printf("Enter in creefichieramr\n");
1092  strcpy (filefich, "cd ");
1093  strcat (filefich, nomdir);
1094  erreur = system (filefich);
1095  if (erreur)
1096  {
1097     strcpy (filefich, "mkdir ");
1098     strcat (filefich, nomdir);
1099     system (filefich);
1100     printf ("%s: Directory created\n", nomdir);
1101  }
1102
1103/******************************************************************************/
1104/******************** Creation of AGRIF_INC files *****************************/
1105/******************************************************************************/
1106
1107/*----------------------------------------------------------------------------*/
1108  if ( todebug == 1 )
1109  {
1110     strcpy(ligne,"initialisations_agrif_");
1111     strcat(ligne,NameTampon);
1112     strcat(ligne,".h");
1113     initproc = associate (ligne);
1114/*----------------------------------------------------------------------------*/
1115     strcpy(ligne,"createvarname_agrif_");
1116     strcat(ligne,NameTampon);
1117     strcat(ligne,".h");
1118     createvarname = associate (ligne);
1119/*----------------------------------------------------------------------------*/
1120     InitEmpty = 1 ;
1121     VarnameEmpty = 1 ;
1122
1123     newvar = List_Global_Var;
1124     while ( newvar && todebug == 1 )
1125     {
1126        donotwrite = 0;
1127        v = newvar->var;
1128
1129        if ( ( v->v_common == 1 || v->v_module == 1 ) && donotwrite == 0 )
1130        {
1131          write_createvarnameagrif_file(v,createvarname,&VarnameEmpty);
1132          write_initialisationsagrif_file(v,initproc,&InitEmpty);
1133        }
1134        newvar = newvar->suiv;
1135     }
1136  /*                                                                          */
1137     fclose (createvarname);
1138     fclose (initproc);
1139  /*--------------------------------------------------------------------------*/
1140     if ( Did_filetoparse_readed(curmodulename) == 0 )
1141     {
1142        if ( InitEmpty != 1  )
1143        {
1144           initglobal = associateaplus("initialisations_agrif.h");
1145           strcpy(ligne,"#include \"initialisations_agrif_");
1146           strcat(ligne,NameTampon);
1147           strcat(ligne,".h\"\n");
1148           fprintf(initglobal,ligne);
1149           fclose(initglobal);
1150        }
1151  /*--------------------------------------------------------------------------*/
1152        if ( VarnameEmpty != 1 )
1153        {
1154           createvarnameglobal= associateaplus("createvarname_agrif.h");
1155           strcpy(ligne,"#include \"createvarname_agrif_");
1156           strcat(ligne,NameTampon);
1157           strcat(ligne,".h\"\n");
1158           fprintf(createvarnameglobal,ligne);
1159           fclose(createvarnameglobal);
1160        }
1161     }
1162  }
1163/*----------------------------------------------------------------------------*/
1164/*----------------------------------------------------------------------------*/
1165/*----------------------------------------------------------------------------*/
1166/*----------------------------------------------------------------------------*/
1167/*----------------------------------------------------------------------------*/
1168  IndiceMax = 0;
1169  IndiceMin = 0;
1170
1171  write_allocation_Common_0();
1172  write_allocation_Global_0();
1173
1174  Write_Alloc_Agrif_Files();
1175  write_probdimagrif_file();
1176  write_keysagrif_file();
1177  write_modtypeagrif_file();
1178  if ( NbMailleXDefined == 1 )
1179                             write_Setnumberofcells_file("SetNumberofcells.h");
1180  if ( NbMailleXDefined == 1 )
1181                             write_Getnumberofcells_file("GetNumberofcells.h");
1182  retour77 = 0;
1183  if ( NbMailleXDefined == 1 )
1184                          write_Setnumberofcells_file("SetNumberofcellsFree.h");
1185  if ( NbMailleXDefined == 1 )
1186                          write_Getnumberofcells_file("GetNumberofcellsFree.h");
1187  retour77 = 1;
1188  if ( NbMailleXDefined == 1 )
1189                         write_Setnumberofcells_file("SetNumberofcellsFixed.h");
1190  if ( NbMailleXDefined == 1 )
1191                         write_Getnumberofcells_file("GetNumberofcellsFixed.h");
1192  if ( todebug == 1 ) printf("Out of creefichieramr\n");
1193}
Note: See TracBrowser for help on using the repository browser.