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

source: branches/2014/dev_r4650_UKMO10_Tidally_Meaned_Diagnostics/NEMOGCM/EXTERNAL/AGRIF/LIB/toamr.c @ 5989

Last change on this file since 5989 was 5989, checked in by deazer, 8 years ago

Merging TMB and 25h diagnostics to head of trunk
added brief documentation

  • Property svn:keywords set to Id
File size: 44.7 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"
39
40const char * tabvarsname(const variable *var)
41{
42    static char * tname[5] = {
43        "tabvars",      // v_catvar == 0
44        "tabvars_c",    // v_catvar == 1
45        "tabvars_r",    // v_catvar == 2
46        "tabvars_l",    // v_catvar == 3
47        "tabvars_i"     // v_catvar == 4
48    };
49    return tname[var->v_catvar];    // v_catvar should never be ouside the range [0:4].
50}
51
52/******************************************************************************/
53/*                        variablecurgridtabvars                              */
54/******************************************************************************/
55/* This subroutine is used to create the string                               */
56/******************************************************************************/
57/*                                                                            */
58/*  ----------->  Agrif_Curgrid % tabvars (i)                                 */
59/*                                                                            */
60/******************************************************************************/
61const char * variablecurgridtabvars(int which_grid)
62{
63    static char * varname[4] = {
64        " Agrif_%s(%d)",                // which_grid == 0
65        " Agrif_%s(%d) %% parent_var",  // which_grid == 1
66        " Agrif_Mygrid %% %s(%d)",      // which_grid == 2
67        " Agrif_Curgrid %% %s(%d)",     // which_grid == 3
68    };
69
70    return varname[which_grid];
71}
72
73void WARNING_CharSize(const variable *var)
74{
75    if ( var->v_nbdim == 0 )
76    {
77        if ( convert2int(var->v_dimchar) > 2400 )
78        {
79            printf("WARNING : The dimension of the character  %s   \n", var->v_nomvar);
80            printf("   is upper than 2400. You must change         \n");
81            printf("   the dimension of carray0                    \n");
82            printf("   in the file AGRIF/AGRIF_FILES/modtypes.F90  \n");
83            printf("   line 161. Replace 2400 with %d.              \n", convert2int(var->v_dimchar)+100);
84        }
85        Save_Length_int(convert2int(var->v_dimchar),1);
86    }
87    else if ( var->v_nbdim == 1 )
88    {
89        if ( convert2int(var->v_dimchar) > 200 )
90        {
91            printf("WARNING : The dimension of the character  %s   \n", var->v_nomvar);
92            printf("   is upper than 200. You must change          \n");
93            printf("   the dimension of carray1                    \n");
94            printf("   in the file AGRIF/AGRIF_FILES/modtypes.F90  \n");
95            printf("   line 162. Replace 200 with %d.              \n", convert2int(var->v_dimchar)+100);
96        }
97        Save_Length_int(convert2int(var->v_dimchar),2);
98    }
99    else if ( var->v_nbdim == 2 )
100    {
101        if ( convert2int(var->v_dimchar) > 200 )
102        {
103            printf("WARNING : The dimension of the character  %s   \n", var->v_nomvar);
104            printf("   is upper than 200. You must change          \n");
105            printf("   the dimension of carray2                    \n");
106            printf("   in the file AGRIF/AGRIF_FILES/modtypes.F90  \n");
107            printf("   line 163. Replace 200 with %d.              \n", convert2int(var->v_dimchar)+100);
108        }
109        Save_Length_int(convert2int(var->v_dimchar),3);
110    }
111    else if ( var->v_nbdim == 3 )
112    {
113        if ( convert2int(var->v_dimchar) > 200 )
114        {
115            printf("WARNING : The dimension of the character  %s   \n", var->v_nomvar);
116            printf("   is upper than 200. You must change          \n");
117            printf("   the dimension of carray3                    \n");
118            printf("   in the file AGRIF/AGRIF_FILES/modtypes.F90  \n");
119            printf("   line 164. Replace 200 with %d.              \n", convert2int(var->v_dimchar)+100);
120        }
121        Save_Length_int(convert2int(var->v_dimchar),4);
122    }
123}
124/******************************************************************************/
125/*                           vargridnametabvars                               */
126/******************************************************************************/
127/* This subroutine is used to create the string                               */
128/******************************************************************************/
129/*                                                                            */
130/*  if iorindice == 0 ----------->  Agrif_Gr % tabvars (i) % array1           */
131/*                                                                            */
132/*  if iorindice == 1 ----------->  Agrif_Gr % tabvars (12) % array1          */
133/*                                                                            */
134/******************************************************************************/
135const char *vargridnametabvars (const variable * var, int iorindice)
136{
137    static char tname_1[LONG_C];
138    static char tname_2[LONG_C];
139
140    if ( iorindice == 0 ) sprintf(tname_1, "Agrif_Gr %% %s(%d)", tabvarsname(var), var->v_indicetabvars);
141    else                  sprintf(tname_1, "Agrif_Gr %% %s(i)",  tabvarsname(var));
142
143    if (!strcasecmp(var->v_typevar, "REAL"))
144    {
145        if      ( !strcasecmp(var->v_nameinttypename,"8") ) sprintf(tname_2, "%% darray%d", var->v_nbdim);
146        else if ( !strcasecmp(var->v_nameinttypename,"4") ) sprintf(tname_2, "%% sarray%d", var->v_nbdim);
147        else                                                sprintf(tname_2, "%% array%d",  var->v_nbdim);
148    }
149    else if (!strcasecmp(var->v_typevar, "integer"))
150    {
151        sprintf(tname_2, "%% iarray%d", var->v_nbdim);
152    }
153    else if (!strcasecmp(var->v_typevar, "logical"))
154    {
155        sprintf(tname_2, "%% larray%d", var->v_nbdim);
156    }
157    else if (!strcasecmp(var->v_typevar, "character"))
158    {
159        WARNING_CharSize(var);
160        sprintf (tname_2, "%% carray%d", var->v_nbdim);
161    }
162
163    strcat(tname_1, tname_2);
164    Save_Length(tname_1, 46);
165
166    return tname_1;
167}
168
169/******************************************************************************/
170/*                           vargridcurgridtabvars                            */
171/******************************************************************************/
172/* This subroutine is used to create the string                               */
173/******************************************************************************/
174/*                                                                            */
175/* if which_grid == 0 -->  Agrif_Curgrid % tabvars (i) % array1               */
176/*                                                                            */
177/* if which_grid == 1 -->  Agrif_tabvars (i) % parent_var % array1            */
178/*                                                                            */
179/* if which_grid == 2 -->  Agrif_Gr % tabvars (i) % array1                    */
180/*                                                                            */
181/******************************************************************************/
182const char *vargridcurgridtabvars(const variable *var, int which_grid)
183{
184    static char tname_1[LONG_C];
185    static char tname_2[LONG_C];
186
187    if (!strcasecmp(var->v_typevar,"type"))
188    {
189        sprintf(tname_1, "Agrif_%s_var(Agrif_Curgrid%%fixedrank)%%%s", var->v_modulename, var->v_nomvar);
190    }
191    else
192    {
193        sprintf(tname_1, variablecurgridtabvars(which_grid), tabvarsname(var), var->v_indicetabvars);
194
195        if (!strcasecmp(var->v_typevar, "REAL"))
196        {
197            if      ( !strcasecmp(var->v_nameinttypename,"8") ) sprintf(tname_2, "%% darray%d", var->v_nbdim);
198            else if ( !strcasecmp(var->v_nameinttypename,"4") ) sprintf(tname_2, "%% sarray%d", var->v_nbdim);
199            else                                                sprintf(tname_2, "%% array%d", var->v_nbdim);
200        }
201        else if (!strcasecmp(var->v_typevar, "INTEGER"))
202        {
203            sprintf(tname_2, "%% iarray%d", var->v_nbdim);
204        }
205        else if (!strcasecmp(var->v_typevar, "LOGICAL"))
206        {
207            sprintf(tname_2, "%% larray%d", var->v_nbdim);
208        }
209        else if (!strcasecmp(var->v_typevar, "CHARACTER"))
210        {
211            WARNING_CharSize(var);
212            sprintf(tname_2, "%% carray%d", var->v_nbdim);
213        }
214        strcat(tname_1, tname_2);
215    }
216    Save_Length(tname_1, 46);
217
218    return tname_1;
219}
220
221/******************************************************************************/
222/*                  vargridcurgridtabvarswithoutAgrif_Gr                      */
223/******************************************************************************/
224/* This subroutine is used to create the string                               */
225/******************************************************************************/
226/*                                                                            */
227/******************************************************************************/
228const char *vargridcurgridtabvarswithoutAgrif_Gr(const variable *var)
229{
230    static char tname_1[LONG_C];
231    static char tname_2[LONG_C];
232
233    sprintf(tname_1, "(%d)", var->v_indicetabvars);
234
235    if (!strcasecmp (var->v_typevar, "REAL"))
236    {
237        if      ( !strcasecmp(var->v_nameinttypename,"8") ) sprintf(tname_2, "%% darray%d", var->v_nbdim);
238        else if ( !strcasecmp(var->v_nameinttypename,"4") ) sprintf(tname_2, "%% sarray%d", var->v_nbdim);
239        else                                                sprintf(tname_2, "%% array%d", var->v_nbdim);
240    }
241    else if (!strcasecmp(var->v_typevar, "INTEGER"))
242    {
243        sprintf(tname_2, "%% iarray%d", var->v_nbdim);
244    }
245    else if (!strcasecmp(var->v_typevar, "LOGICAL"))
246    {
247        sprintf(tname_2, "%% larray%d", var->v_nbdim);
248    }
249    else if (!strcasecmp(var->v_typevar, "CHARACTER"))
250    {
251        WARNING_CharSize(var);
252        sprintf(tname_2, "%% carray%d", var->v_nbdim);
253    }
254
255    strcat(tname_1, tname_2);
256    Save_Length(tname_1, 46);
257
258    return tname_1;
259}
260
261/******************************************************************************/
262/*                               vargridparam                                 */
263/******************************************************************************/
264/* This subroutine is used to create the string which contains                */
265/* dimension list                                                             */
266/******************************************************************************/
267/*                                                                            */
268/*  DIMENSION(jpi,0:jpj) ----------->"1:jpi,0:jpj"                            */
269/*                                                                            */
270/******************************************************************************/
271const char * vargridparam(const variable *var)
272{
273    typedim dim;
274    listdim *newdim;
275    char newname[LONG_M];
276
277    newdim = var->v_dimension;
278    if (!newdim) return "";
279
280    strcpy (tmpvargridname, "(");
281    while (newdim)
282    {
283        dim = newdim->dim;
284        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(dim.first,List_Global_Var));
285        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_Common_Var));
286        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_ModuleUsed_Var));
287        strcat(tmpvargridname, newname);
288        strcat(tmpvargridname, " : ");
289        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(dim.last,List_Global_Var));
290        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname, List_Common_Var));
291        strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname, List_ModuleUsed_Var));
292        strcat(tmpvargridname, newname);
293        newdim = newdim->suiv;
294        if (newdim) strcat(tmpvargridname, ",");
295    }
296    strcat(tmpvargridname, ")\0");
297    Save_Length(tmpvargridname,40);
298    return tmpvargridname;
299}
300
301/******************************************************************************/
302/*                        write_probdimagrif_file                             */
303/******************************************************************************/
304/* This subroutine is used to create the file probdim_agrif.h                 */
305/******************************************************************************/
306/*                                                                            */
307/*               probdim_agrif.h                                              */
308/*                                                                            */
309/*               Agrif_probdim = <number>                                     */
310/*                                                                            */
311/******************************************************************************/
312void write_probdimagrif_file()
313{
314  FILE *probdim;
315  char ligne[LONG_M];
316
317  probdim = open_for_write("probdim_agrif.h");
318  sprintf (ligne, "Agrif_Probdim = %d", dimprob);
319  tofich (probdim, ligne,1);
320  fclose (probdim);
321}
322
323/******************************************************************************/
324/*                             write_keysagrif_file                           */
325/******************************************************************************/
326/* This subroutine is used to create the file keys_agrif.h                    */
327/******************************************************************************/
328/*                                                                            */
329/*               keys_agrif.h                                                 */
330/*                                                                            */
331/*               AGRIF_USE_FIXED_GRIDS = 0                                    */
332/*               AGRIF_USE_ONLY_FIXED_GRIDS = 0                               */
333/*               AGRIF_USE_(ONLY)_FIXED_GRIDS = 1                             */
334/*                                                                            */
335/******************************************************************************/
336void write_keysagrif_file()
337{
338  FILE *keys;
339
340  keys = open_for_write("keys_agrif.h");
341  fprintf(keys,"      AGRIF_USE_FIXED_GRIDS = %d\n", fixedgrids);
342  fprintf(keys,"      AGRIF_USE_ONLY_FIXED_GRIDS = %d\n", onlyfixedgrids);
343  fclose(keys);
344}
345
346/******************************************************************************/
347/*                      write_modtypeagrif_file                               */
348/******************************************************************************/
349/* This subroutine is used to create the file typedata                        */
350/******************************************************************************/
351/*                                                                            */
352/*               modtype_agrif.h                                              */
353/*                                                                            */
354/*               Agrif_NbVariables =                                          */
355/*                                                                            */
356/******************************************************************************/
357void write_modtypeagrif_file()
358{
359  char ligne[LONG_M];
360  FILE *typedata;
361  int i;
362
363  typedata = open_for_write("modtype_agrif.h");
364  /* AGRIF_NbVariables : number of variables                                  */
365  for (i=0;i<NB_CAT_VARIABLES;i++)
366   {
367    sprintf (ligne, "Agrif_NbVariables(%d) = %d",i,indicemaxtabvars[i]);
368    tofich(typedata,ligne,1);
369   }
370  fclose (typedata);
371}
372
373/******************************************************************************/
374/*                   write_createvarnameagrif_file                            */
375/******************************************************************************/
376/* This subroutine is used to create the file  createvarname                  */
377/******************************************************************************/
378/*                                                                            */
379/*    Agrif_Gr % tabvars (i) % namevar = "variable"                           */
380/*                                                                            */
381/******************************************************************************/
382void write_createvarnameagrif_file(variable *v,FILE *createvarname, int *InitEmpty)
383{
384    char ligne[LONG_M];
385
386    *InitEmpty = 0 ;
387    sprintf(ligne, "Agrif_Gr %% %s(%d) %% namevar = \"%s\"",tabvarsname(v),v->v_indicetabvars,v->v_nomvar);
388    tofich(createvarname,ligne,1);
389}
390
391/******************************************************************************/
392/*                        write_Setnumberofcells_file                         */
393/******************************************************************************/
394/* This subroutine is used to create the file  setnumberofcells               */
395/******************************************************************************/
396/*                                                                            */
397/*              Agrif_Gr % n(i) = nbmailles                                   */
398/*                                                                            */
399/******************************************************************************/
400void write_Setnumberofcells_file()
401{
402    char ligne[LONG_VNAME];
403    char cformat[LONG_VNAME];
404    FILE *setnumberofcells;
405
406    if ( IndicenbmaillesX == 0 )  return;
407
408    setnumberofcells = open_for_write("SetNumberofcells.h");
409
410    if ( onlyfixedgrids == 1 )
411        strcpy(cformat, "Agrif_Gr %% nb(%d) = Agrif_Curgrid %% tabvars_i(%d) %% iarray0");
412    else
413        strcpy(cformat, "Agrif_Gr %% nb(%d) = Agrif_Gr %% tabvars_i(%d) %% iarray0");
414
415    sprintf(ligne, cformat, 1, IndicenbmaillesX);
416    tofich(setnumberofcells, ligne, 1);
417
418    if ( dimprob > 1 )
419    {
420        sprintf(ligne, cformat, 2, IndicenbmaillesY);
421        tofich(setnumberofcells, ligne, 1);
422    }
423    if ( dimprob > 2 )
424    {
425        sprintf(ligne, cformat, 3, IndicenbmaillesZ);
426        tofich(setnumberofcells, ligne, 1);
427    }
428    fclose(setnumberofcells);
429}
430
431/******************************************************************************/
432/*                       write_Getnumberofcells_file                          */
433/******************************************************************************/
434/* This subroutine is used to create the file  getnumberofcells               */
435/******************************************************************************/
436/*                                                                            */
437/*              nbmailles = Agrif_Gr % n(i)                                   */
438/*                                                                            */
439/******************************************************************************/
440void write_Getnumberofcells_file()
441{
442    char ligne[LONG_VNAME];
443    char cformat[LONG_VNAME];
444    FILE *getnumberofcells;
445
446    if ( IndicenbmaillesX == 0 )    return;
447
448    strcpy(cformat, "Agrif_Curgrid %% tabvars_i(%d) %% iarray0 = Agrif_Gr %% nb(%d)");
449
450    getnumberofcells = open_for_write("GetNumberofcells.h");
451
452    sprintf(ligne, cformat, IndicenbmaillesX, 1);
453    tofich(getnumberofcells, ligne, 1);
454
455    if (dimprob > 1)
456    {
457        sprintf(ligne, cformat, IndicenbmaillesY, 2);
458        tofich(getnumberofcells, ligne,1);
459    }
460    if (dimprob > 2)
461    {
462        sprintf(ligne, cformat, IndicenbmaillesZ, 3);
463        tofich(getnumberofcells, ligne,1);
464    }
465    fclose(getnumberofcells);
466}
467
468
469/******************************************************************************/
470/*                      write_initialisationsagrif_file                       */
471/******************************************************************************/
472/* This subroutine is used to create the file initproc                        */
473/******************************************************************************/
474/*                                                                            */
475/*              ! variable                                                    */
476/*              Agrif_Gr % tabvars(i) % nbdim = 1                             */
477/*                                                                            */
478/******************************************************************************/
479void write_initialisationsagrif_file(variable *v,FILE *initproc,int *VarnameEmpty)
480{
481    char ligne[LONG_M];
482
483    if ( v->v_nbdim != 0 )
484    {
485        *VarnameEmpty = 0 ;
486        sprintf(ligne,"Agrif_Mygrid %% %s(%d) %% nbdim = %d", tabvarsname(v), v->v_indicetabvars, v->v_nbdim);
487        tofich (initproc, ligne,1);
488    }
489}
490
491
492void Write_Alloc_Agrif_Files()
493{
494   listnom *parcours;
495   FILE *alloccalls;
496   FILE *AllocUSE;
497
498   AllocUSE= open_for_write("include_use_Alloc_agrif.h");
499   alloccalls = open_for_write("allocations_calls_agrif.h");
500
501   parcours = List_Subroutine_For_Alloc;
502   while ( parcours )
503   {
504      fprintf(AllocUSE,"      use %s, only: Alloc_agrif_%s\n", parcours -> o_nom, parcours -> o_nom );
505      fprintf (alloccalls,"      call Alloc_agrif_%s(Agrif_Gr)\n", parcours -> o_nom );
506      parcours = parcours -> suiv;
507   }
508
509   fclose (AllocUSE);
510   fclose (alloccalls);
511}
512
513int IndiceInlist(int indic, listindice *listin)
514{
515   listindice *parcoursindic;
516   int out;
517
518   out = 0 ;
519
520   parcoursindic = listin;
521   while ( parcoursindic && out == 0 )
522   {
523      if ( parcoursindic->i_indice == indic ) out = 1;
524      else parcoursindic = parcoursindic -> suiv;
525   }
526
527   return out;
528}
529
530void write_allocation_Common_0()
531{
532    listnom *parcours_nom;
533    listnom *neededparameter;
534    listvar *parcours;
535    listvar *parcoursprec;
536    listvar *parcours1;
537    FILE *allocationagrif;
538    FILE *paramtoamr;
539    char ligne[LONG_M];
540    char ligne2[LONG_M];
541    variable *v;
542    int IndiceMax;
543    int IndiceMin;
544    int compteur;
545    int out;
546    int indiceprec;
547    int ValeurMax;
548    char initialvalue[LONG_M];
549    listindice **list_indic;
550    listindice *parcoursindic;
551    int i;
552
553    parcoursprec = (listvar *) NULL;
554    parcours_nom = List_NameOfCommon;
555    ValeurMax = 2;
556    while ( parcours_nom  )
557    {
558        if ( parcours_nom->o_val == 1 )
559        {
560            /* Open the file to create the Alloc_agrif subroutine                */
561            sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom);
562            allocationagrif = open_for_write(ligne);
563            fprintf(allocationagrif,"#include \"Param_toamr_%s.h\" \n", parcours_nom->o_nom);
564
565            sprintf(ligne,"Param_toamr_%s.h",parcours_nom->o_nom);
566            paramtoamr = open_for_write(ligne);
567            neededparameter = (listnom *) NULL;
568            list_indic = (listindice **) calloc(NB_CAT_VARIABLES,sizeof(listindice *));
569
570//             shouldincludempif = 1 ;
571            parcours = List_Common_Var;
572            while ( parcours )
573            {
574                if ( !strcasecmp(parcours->var->v_commonname,parcours_nom->o_nom) &&
575                    IndiceInlist(parcours->var->v_indicetabvars,list_indic[parcours->var->v_catvar]) == 0 )
576                {
577                    v = parcours->var;
578                    IndiceMax = 0;
579                    IndiceMin = indicemaxtabvars[v->v_catvar];
580                    /* body of the file */
581                    if ( !strcasecmp(v->v_commoninfile,cur_filename) )
582                    {
583                        if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) )
584                        {
585                            sprintf(ligne,"if (.not. allocated(%s)) then", vargridnametabvars(v,0));
586                            tofich(allocationagrif,ligne,1);
587                        }
588                        if ( (v->v_allocatable != 1) && (v->v_dimsempty != 1) )
589                        {
590                            /*                ALLOCATION                                          */
591                            if ( v->v_dimension != 0 )
592                            {
593                                if ( v->v_indicetabvars < IndiceMin || v->v_indicetabvars > IndiceMax )
594                                {
595                                    parcours1 = parcours;
596                                    compteur = -1;
597                                    out = 0;
598                                    indiceprec = parcours->var->v_indicetabvars -1 ;
599                                    while ( parcours1 && out == 0
600                                        && !strcasecmp(parcours->var->v_readedlistdimension,parcours1->var->v_readedlistdimension)
601                                        && !strcasecmp(parcours->var->v_typevar,            parcours1->var->v_typevar)
602                                        && (parcours1->var->v_indicetabvars == indiceprec+1) )
603                                    {
604                                        if ( !strcasecmp(parcours1->var->v_modulename,parcours_nom->o_nom) ||
605                                             !strcasecmp(parcours1->var->v_commonname,parcours_nom->o_nom) )
606                                        {
607                                            compteur = compteur +1 ;
608                                            indiceprec = parcours1->var->v_indicetabvars;
609                                            parcoursprec = parcours1;
610                                            parcours1 = parcours1->suiv;
611                                        }
612                                        else out = 1;
613                                    }
614                                    sprintf(ligne,"!! ALLOCATION OF VARIABLE : %s",v->v_nomvar);
615                                    tofich(allocationagrif,ligne,1);
616                                    if ( compteur > ValeurMax )
617                                    {
618                                        sprintf(ligne,"do i = %d,%d", parcours->var->v_indicetabvars,
619                                                                      parcours->var->v_indicetabvars+compteur);
620                                        tofich(allocationagrif,ligne,1);
621                                        IndiceMin = parcours->var->v_indicetabvars;
622                                        IndiceMax = parcours->var->v_indicetabvars+compteur;
623                                        sprintf(ligne,"    allocate(%s", vargridnametabvars(v,1));
624                                        sprintf(ligne2,"%s)", vargridparam(v));
625                                        strcat(ligne,ligne2);
626                                        tofich(allocationagrif,ligne,1);
627                                        tofich(allocationagrif,"enddo",1);
628                                        i = parcours->var->v_indicetabvars;
629                                        do
630                                        {
631                                            parcoursindic =  (listindice *)calloc(1,sizeof(listindice));
632                                            parcoursindic -> i_indice = i;
633                                            parcoursindic -> suiv = list_indic[parcours->var->v_catvar];
634                                            list_indic[parcours->var->v_catvar] = parcoursindic;
635                                            i = i + 1;
636                                        } while ( i <= parcours->var->v_indicetabvars+compteur );
637                                        parcours = parcoursprec;
638                                    }
639                                    else
640                                    {
641                                        sprintf(ligne,"allocate(%s", vargridnametabvars(v,0));
642                                        sprintf(ligne2,"%s)", vargridparam(v));
643                                        strcat(ligne,ligne2);
644                                        tofich(allocationagrif,ligne,1);
645                                        parcoursindic =  (listindice *) calloc(1,sizeof(listindice));
646                                        parcoursindic -> i_indice = parcours->var->v_indicetabvars;
647                                        parcoursindic -> suiv = list_indic[parcours->var->v_catvar];
648                                        list_indic[parcours->var->v_catvar] = parcoursindic;
649                                    }
650                                    neededparameter = writedeclarationintoamr(List_Parameter_Var,
651                                                        paramtoamr,v,parcours_nom->o_nom,neededparameter,v->v_commonname);
652                                }
653                            } /* end of the allocation part                                       */
654                            /*                INITIALISATION                                      */
655                            if ( strcasecmp(v->v_initialvalue,"") )
656                            {
657                                strcpy(ligne, vargridnametabvars(v,0));
658                                /* We should modify the initialvalue in the case of variable has been defined with others variables */
659                                strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Global_Var));
660                                if ( !strcasecmp(initialvalue,v->v_initialvalue) )
661                                {
662                                    strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Common_Var));
663                                }
664                                if ( !strcasecmp(initialvalue,v->v_initialvalue) )
665                                {
666                                    strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_ModuleUsed_Var));
667                                }
668                                strcat (ligne," = ");
669
670                                if (v->v_nbdim == 0)
671                                {
672                                    strcpy(ligne2,initialvalue);
673                                }
674                                else
675                                {
676                                    sprintf(ligne2,"reshape(%s,shape(%s))",initialvalue,vargridnametabvars(v,0));
677                                }
678                                strcat(ligne,ligne2);
679                                tofich(allocationagrif,ligne,1);
680                            }
681                        }
682                        if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) )
683                        {
684                            tofich(allocationagrif,"endif",1);
685                        }
686                    }
687                }
688                parcours = parcours -> suiv;
689            }
690            /* Close the file Alloc_agrif                                        */
691            fclose(allocationagrif);
692            fclose(paramtoamr);
693        }
694        parcours_nom = parcours_nom -> suiv;
695    }
696}
697
698void write_allocation_Global_0()
699{
700    listnom *parcours_nom;
701    listvar *parcours;
702    listvar *parcoursprec;
703    listvar *parcours1;
704    FILE *allocationagrif;
705    char ligne[LONG_M];
706    char ligne2[LONG_M];
707    variable *v;
708    int IndiceMax;
709    int IndiceMin;
710    int compteur;
711    int out;
712    int indiceprec;
713    int ValeurMax;
714    char initialvalue[LONG_M];
715    int typeiswritten ;
716
717    parcoursprec = (listvar *) NULL;
718    parcours_nom = List_NameOfModule;
719    ValeurMax = 2;
720
721    while ( parcours_nom  )
722    {
723        if ( parcours_nom->o_val == 1 )
724        {
725            IndiceMax = 0;
726            IndiceMin = indicemaxtabvars[0];
727            /* Open the file to create the Alloc_agrif subroutine                */
728            sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom);
729            allocationagrif = open_for_write(ligne);
730
731//             if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 )
732//             {
733//                 /* add the call to initworkspace         */
734//                 tofich(allocationagrif,"if (.not. Agrif_Root() ) then",1);
735//                 tofich(allocationagrif,"#include \"GetNumberofcells.h\"\n",0);
736//                 tofich(allocationagrif,"else",1);
737//                 tofich(allocationagrif,"#include \"SetNumberofcells.h\"\n",0);
738//                 tofich(allocationagrif,"endif",1);
739//                 tofich(allocationagrif,"call Agrif_InitWorkspace",1);
740//             }
741
742            typeiswritten = 0;
743            parcours = List_Global_Var;
744            while ( parcours )
745            {
746                if ( !strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom) &&
747                       parcours->var->v_VariableIsParameter == 0                  &&
748                       parcours->var->v_notgrid == 0  )
749                {
750                    v = parcours->var;
751                    IndiceMax = 0;
752                    IndiceMin = indicemaxtabvars[v->v_catvar];
753                    /* body of the file */
754                    if ( !strcasecmp(v->v_commoninfile,cur_filename) )
755                    {
756                        if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) )
757                        {
758                            sprintf(ligne,"if (.not. allocated(%s)) then", vargridnametabvars(v,0));
759                            tofich(allocationagrif,ligne,1);
760                        }
761                        if ( (v->v_allocatable != 1) && (v->v_dimsempty != 1) )
762                        {
763                            /*                ALLOCATION                                          */
764                            if ( v->v_dimension != 0 )
765                            {
766                                if ( v->v_indicetabvars < IndiceMin || v->v_indicetabvars > IndiceMax )
767                                {
768                                    parcours1 = parcours;
769                                    compteur = -1;
770                                    out = 0;
771                                    indiceprec = parcours->var->v_indicetabvars -1 ;
772                                    while ( parcours1 && out == 0
773                                        && !strcasecmp(parcours->var->v_readedlistdimension,parcours1->var->v_readedlistdimension)
774                                        && !strcasecmp(parcours->var->v_typevar,            parcours1->var->v_typevar)
775                                        && (parcours1->var->v_indicetabvars == indiceprec+1) )
776                                    {
777                                        if ( !strcasecmp(parcours1->var->v_modulename, parcours_nom->o_nom) ||
778                                             !strcasecmp(parcours1->var->v_commonname, parcours_nom->o_nom) )
779                                        {
780                                            compteur = compteur +1 ;
781                                            indiceprec = parcours1->var->v_indicetabvars;
782                                            parcoursprec = parcours1;
783                                            parcours1 = parcours1->suiv;
784                                        }
785                                        else out = 1;
786                                    }
787                                    sprintf(ligne,"!! ALLOCATION OF VARIABLE : %s",v->v_nomvar);
788                                    tofich(allocationagrif,ligne,1);
789                                    if ( compteur > ValeurMax )
790                                    {
791                                        sprintf(ligne,"do i = %d,%d", parcours->var->v_indicetabvars,
792                                                                      parcours->var->v_indicetabvars+compteur);
793                                        tofich(allocationagrif,ligne,1);
794                                        IndiceMin = parcours->var->v_indicetabvars;
795                                        IndiceMax = parcours->var->v_indicetabvars+compteur;
796                                        sprintf(ligne,"    allocate(%s", vargridnametabvars(v,1));
797                                        sprintf(ligne2,"%s)", vargridparam(v));
798                                        strcat(ligne,ligne2);
799                                        tofich(allocationagrif,ligne,1);
800                                        tofich(allocationagrif,"enddo",1);
801                                        parcours = parcoursprec;
802                                    }
803                                    else
804                                    {
805                                        sprintf(ligne,"allocate(%s", vargridnametabvars(v,0));
806                                        sprintf(ligne2,"%s)", vargridparam(v));
807                                        strcat(ligne,ligne2);
808                                        tofich(allocationagrif,ligne,1);
809                                    }
810                                }
811                            } /* end of the allocation part                                       */
812                            /*                INITIALISATION                                      */
813                            if ( strcasecmp(v->v_initialvalue,"") )
814                            {
815                                strcpy(ligne, vargridnametabvars(v,0));
816                                /* We should modify the initialvalue in the case of variable has been defined with others variables */
817                                strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Global_Var));
818                                if ( !strcasecmp(initialvalue,v->v_initialvalue) )
819                                {
820                                    strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Common_Var));
821                                }
822                                if ( !strcasecmp(initialvalue,v->v_initialvalue) )
823                                {
824                                    strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_ModuleUsed_Var));
825                                }
826                                strcat (ligne," = ");
827                                strcat (ligne,initialvalue);
828                                Save_Length(ligne,48);
829                                tofich(allocationagrif,ligne,1);
830                            }
831                        }
832                        /* Case of structure types */
833                        if ( (typeiswritten == 0) && !strcasecmp(v->v_typevar,"type") )
834                        {
835                            sprintf(ligne,"if (.not. allocated(Agrif_%s_var)) then",v->v_modulename);
836                            tofich(allocationagrif, ligne, 1);
837                            sprintf(ligne,"    allocate(Agrif_%s_var(0:Agrif_NbMaxGrids))",v->v_modulename);
838                            tofich(allocationagrif, ligne, 1);
839                            tofich(allocationagrif, "endif", 1);
840                            typeiswritten = 1;
841                        }
842                        if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) )
843                        {
844                            tofich(allocationagrif,"endif",1);
845                        }
846                    }
847                }
848                parcours = parcours -> suiv;
849            }
850            if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 )
851            {
852                fprintf(allocationagrif, "      if ( .not.Agrif_Root() ) then\n");
853                fprintf(allocationagrif, "#include \"GetNumberofcells.h\"\n");
854                fprintf(allocationagrif, "      else\n");
855                fprintf(allocationagrif, "#include \"SetNumberofcells.h\"\n");
856                fprintf(allocationagrif, "      endif\n");
857                fprintf(allocationagrif, "      call Agrif_InitWorkspace\n");
858            }
859            fclose(allocationagrif);
860        }
861        parcours_nom = parcours_nom -> suiv;
862    }
863}
864
865/******************************************************************************/
866/*                           creefichieramr                                   */
867/******************************************************************************/
868/* This subroutine is the main one to create AGRIF_INC files                  */
869/******************************************************************************/
870/*                                                                            */
871/******************************************************************************/
872void creefichieramr ()
873{
874    listvar *newvar;
875    variable *v;
876    int erreur;
877    char filefich[LONG_M];
878
879    int InitEmpty;
880    int VarnameEmpty;
881    int donotwrite;
882
883    FILE *initproc;
884    FILE *initglobal;
885    FILE *createvarname;
886    FILE *createvarnameglobal;
887
888    if ( todebug == 1 ) printf("Enter in creefichieramr\n");
889
890    sprintf(filefich, "cd %s", include_dir);
891    erreur = system (filefich);
892    if (erreur)
893    {
894        sprintf(filefich, "mkdir -p %s", include_dir);
895        system(filefich);
896        printf("%s: Directory created\n", include_dir);
897    }
898
899/******************************************************************************/
900/******************** Creation of AGRIF_INC files *****************************/
901/******************************************************************************/
902
903    if ( todebug == 1 )
904    {
905        const char *NameTampon = "toto";
906        sprintf(filefich,"initialisations_agrif_%s.h", NameTampon);
907        initproc = open_for_write(filefich);
908
909        sprintf(filefich,"createvarname_agrif_%s.h", NameTampon);
910        createvarname = open_for_write(filefich);
911
912        InitEmpty = 1 ;
913        VarnameEmpty = 1 ;
914
915        newvar = List_Global_Var;
916        while ( newvar )
917        {
918            donotwrite = 0;
919            v = newvar->var;
920
921            if ( ( v->v_common == 1 || v->v_module == 1 ) && donotwrite == 0 )
922            {
923                write_createvarnameagrif_file(v,createvarname,&VarnameEmpty);
924                write_initialisationsagrif_file(v,initproc,&InitEmpty);
925            }
926            newvar = newvar->suiv;
927        }
928        fclose (createvarname);
929        fclose (initproc);
930
931        if ( is_dependfile_created(curmodulename) == 0 )
932        {
933            if ( InitEmpty != 1  )
934            {
935                initglobal = open_for_append("initialisations_agrif.h");
936                fprintf(initglobal,"#include \"initialisations_agrif_%s.h\"\n", NameTampon);
937                fclose(initglobal);
938            }
939            if ( VarnameEmpty != 1 )
940            {
941                createvarnameglobal= open_for_append("createvarname_agrif.h");
942                fprintf(createvarnameglobal,"#include \"createvarname_agrif_%s.h\"\n", NameTampon);
943                fclose(createvarnameglobal);
944            }
945        }
946    }
947    write_allocation_Common_0();
948    write_allocation_Global_0();
949
950    Write_Alloc_Agrif_Files();
951    write_probdimagrif_file();
952    write_keysagrif_file();
953    write_modtypeagrif_file();
954
955    if ( NbMailleXDefined == 1 )
956    {
957        write_Setnumberofcells_file();
958        write_Getnumberofcells_file();
959    }
960
961    if ( todebug == 1 ) printf("Out of creefichieramr\n");
962}
Note: See TracBrowser for help on using the repository browser.