source: branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/EXTERNAL/AGRIF/LIB/Writedeclarations.c @ 5445

Last change on this file since 5445 was 5445, checked in by davestorkey, 5 years ago

Clear SVN keywords from 2015/dev_r5021_UKMO1_CICE_coupling branch.

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