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 branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/EXTERNAL/AGRIF/LIB – NEMO

source: branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/EXTERNAL/AGRIF/LIB/toamr.c @ 5984

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

Clear svn keywords to allow use with fcm make

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