[1901] | 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 | /******************************************************************************/ |
---|
[5656] | 52 | void WriteBeginDeclaration(variable *v, char line[LONG_M], int visibility) |
---|
[1901] | 53 | { |
---|
[5656] | 54 | char tmpligne[LONG_M]; |
---|
| 55 | int precision_given ; |
---|
[1901] | 56 | |
---|
| 57 | if ( !strcasecmp(v->v_typevar,"") ) |
---|
| 58 | { |
---|
[5656] | 59 | printf("# WARNING : The type of the variable %s is unknown.\n", v->v_nomvar); |
---|
| 60 | printf("# CONV should define a type\n"); |
---|
[1901] | 61 | } |
---|
[5656] | 62 | |
---|
| 63 | sprintf(line, "%s", v->v_typevar); |
---|
| 64 | if ( v->v_c_star == 1 ) strcat(line, "*"); |
---|
| 65 | |
---|
[1901] | 66 | /* We should give the precision of the variable if it has been given */ |
---|
[5656] | 67 | precision_given = 0; |
---|
[10088] | 68 | |
---|
[1901] | 69 | if ( strcasecmp(v->v_precision,"") ) |
---|
| 70 | { |
---|
[5656] | 71 | sprintf(tmpligne, "(%s)", v->v_precision); |
---|
| 72 | Save_Length(tmpligne, 49); |
---|
| 73 | strcat(line, tmpligne); |
---|
| 74 | precision_given = 1; |
---|
[1901] | 75 | } |
---|
[5656] | 76 | |
---|
[1901] | 77 | if (strcasecmp(v->v_dimchar,"")) |
---|
| 78 | { |
---|
| 79 | sprintf(tmpligne,"(%s)",v->v_dimchar); |
---|
[5656] | 80 | Save_Length(tmpligne, 49); |
---|
| 81 | strcat(line,tmpligne); |
---|
[1901] | 82 | } |
---|
[5656] | 83 | |
---|
| 84 | if ((precision_given == 0) && ( strcasecmp(v->v_nameinttypename,"") )) |
---|
[1901] | 85 | { |
---|
| 86 | sprintf(tmpligne,"*%s",v->v_nameinttypename); |
---|
[5656] | 87 | Save_Length(tmpligne, 49); |
---|
| 88 | strcat(line,tmpligne); |
---|
[1901] | 89 | } |
---|
| 90 | if (strcasecmp (v->v_IntentSpec, "")) |
---|
| 91 | { |
---|
[5656] | 92 | sprintf(tmpligne,", intent(%s)", v->v_IntentSpec); |
---|
| 93 | Save_Length(tmpligne, 49); |
---|
| 94 | strcat(line,tmpligne); |
---|
[1901] | 95 | } |
---|
[5656] | 96 | if ( v->v_VariableIsParameter ) strcat(line, ", parameter"); |
---|
| 97 | if ( visibility ) |
---|
[1901] | 98 | { |
---|
[5656] | 99 | if ( v->v_PublicDeclare ) strcat(line, ", public"); |
---|
| 100 | if ( v->v_PrivateDeclare ) strcat(line, ", private"); |
---|
[1901] | 101 | } |
---|
[5656] | 102 | if ( v->v_ExternalDeclare ) strcat(line, ", external"); |
---|
| 103 | if ( v->v_allocatable ) strcat(line, ", allocatable"); |
---|
| 104 | if ( v->v_target ) strcat(line, ", target"); |
---|
| 105 | if ( v->v_optionaldeclare ) strcat(line, ", optional"); |
---|
| 106 | if ( v->v_pointerdeclare ) strcat(line, ", pointer"); |
---|
| 107 | Save_Length(line, 45); |
---|
[1901] | 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 | /******************************************************************************/ |
---|
[5656] | 122 | void WriteScalarDeclaration( variable *v, char line[LONG_M]) |
---|
[1901] | 123 | { |
---|
[5656] | 124 | strcat(line, " :: "); |
---|
| 125 | strcat(line, v->v_nomvar); |
---|
[1901] | 126 | |
---|
[5656] | 127 | if ( strcasecmp(v->v_vallengspec, "") ) strcat(line,v->v_vallengspec); |
---|
| 128 | if ( v->v_VariableIsParameter ) |
---|
| 129 | { |
---|
| 130 | strcat(line," = "); |
---|
[10088] | 131 | strcat(line, v->v_initialvalue->n_name); |
---|
[5656] | 132 | } |
---|
| 133 | Save_Length(line, 45); |
---|
[1901] | 134 | } |
---|
| 135 | |
---|
| 136 | /******************************************************************************/ |
---|
| 137 | /* WriteTableDeclaration */ |
---|
| 138 | /******************************************************************************/ |
---|
| 139 | /* This subroutine is used to write a Table declaration */ |
---|
| 140 | /* taken in a variable record */ |
---|
| 141 | /* */ |
---|
| 142 | /******************************************************************************/ |
---|
| 143 | /* */ |
---|
| 144 | /* integer variable(nb) -----------> */ |
---|
| 145 | /* INTEGER, DIMENSION(1:nb) :: variable */ |
---|
| 146 | /* */ |
---|
| 147 | /******************************************************************************/ |
---|
[5656] | 148 | void WriteTableDeclaration(variable * v,char ligne[LONG_M],int tmpok) |
---|
[1901] | 149 | { |
---|
[5656] | 150 | char newname[LONG_M]; |
---|
[1901] | 151 | |
---|
[5656] | 152 | strcat (ligne, ", dimension("); |
---|
[1901] | 153 | |
---|
[5656] | 154 | if ( v->v_dimensiongiven == 1 && tmpok == 1 ) strcat(ligne,v->v_readedlistdimension); |
---|
| 155 | if ( v->v_dimensiongiven == 1 && tmpok == 0 ) |
---|
| 156 | { |
---|
| 157 | strcpy(newname,ChangeTheInitalvaluebyTabvarsName(v->v_readedlistdimension,List_Global_Var)); |
---|
| 158 | if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension); |
---|
[1901] | 159 | |
---|
[5656] | 160 | strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_Common_Var)); |
---|
| 161 | if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension); |
---|
[1901] | 162 | |
---|
[5656] | 163 | strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_ModuleUsed_Var)); |
---|
[1901] | 164 | if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension); |
---|
| 165 | |
---|
[5656] | 166 | Save_Length(newname,47); |
---|
| 167 | strcat(ligne,newname); |
---|
| 168 | } |
---|
| 169 | strcat(ligne, ") :: "); |
---|
| 170 | strcat(ligne, v->v_nomvar); |
---|
| 171 | if ( strcasecmp(vallengspec,"") ) strcat(ligne,v->v_vallengspec); |
---|
[1901] | 172 | |
---|
[5656] | 173 | if ( v->v_VariableIsParameter == 1 ) |
---|
| 174 | { |
---|
| 175 | strcat(ligne," = "); |
---|
[10088] | 176 | strcat(ligne,v->v_initialvalue->n_name); |
---|
[5656] | 177 | } |
---|
| 178 | Save_Length(ligne,45); |
---|
[1901] | 179 | } |
---|
| 180 | |
---|
| 181 | /******************************************************************************/ |
---|
[5656] | 182 | /* WriteVarDeclaration */ |
---|
[1901] | 183 | /******************************************************************************/ |
---|
| 184 | /* This subroutine is used to write the initial declaration in the file */ |
---|
| 185 | /* fileout of a variable */ |
---|
| 186 | /* */ |
---|
| 187 | /******************************************************************************/ |
---|
| 188 | /* */ |
---|
| 189 | /* integer variable(nb) -----------> */ |
---|
| 190 | /* INTEGER, DIMENSION(1:nb),Pointer :: variable */ |
---|
| 191 | /* */ |
---|
| 192 | /******************************************************************************/ |
---|
[5656] | 193 | void WriteVarDeclaration( variable *v, FILE *fileout, int value, int visibility ) |
---|
[1901] | 194 | { |
---|
| 195 | FILE *filecommon; |
---|
[5656] | 196 | char ligne[LONG_M]; |
---|
[1901] | 197 | |
---|
[5656] | 198 | filecommon = fileout; |
---|
| 199 | |
---|
| 200 | if ( v->v_save == 0 || inmodulemeet == 0 ) |
---|
[1901] | 201 | { |
---|
[5656] | 202 | WriteBeginDeclaration(v, ligne, visibility); |
---|
[1901] | 203 | |
---|
[5656] | 204 | if ( v->v_nbdim == 0 ) |
---|
| 205 | WriteScalarDeclaration(v, ligne); |
---|
| 206 | else |
---|
| 207 | WriteTableDeclaration(v, ligne, value); |
---|
[1901] | 208 | |
---|
[10088] | 209 | if ( v->v_VariableIsParameter != 1 && v->v_initialvalue) |
---|
[1901] | 210 | { |
---|
| 211 | strcat(ligne," = "); |
---|
[10088] | 212 | strcat(ligne,v->v_initialvalue->n_name); |
---|
[1901] | 213 | } |
---|
[5656] | 214 | tofich(filecommon, ligne, 1); |
---|
[1901] | 215 | } |
---|
[5656] | 216 | else |
---|
| 217 | printf("-- in writevardeclaration : |%s| -- MHCHECK\n", v->v_nomvar); |
---|
[1901] | 218 | Save_Length(ligne,45); |
---|
| 219 | } |
---|
| 220 | |
---|
| 221 | |
---|
[5656] | 222 | void WriteLocalParamDeclaration(FILE* tofile) |
---|
[1901] | 223 | { |
---|
[5656] | 224 | listvar *parcours; |
---|
[1901] | 225 | |
---|
[5656] | 226 | parcours = List_Parameter_Var; |
---|
| 227 | while ( parcours ) |
---|
| 228 | { |
---|
| 229 | if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) ) |
---|
| 230 | { |
---|
| 231 | WriteVarDeclaration(parcours->var, tofile, 0, 1); |
---|
| 232 | } |
---|
| 233 | parcours = parcours -> suiv; |
---|
| 234 | } |
---|
[1901] | 235 | } |
---|
| 236 | |
---|
[5656] | 237 | void WriteFunctionDeclaration(FILE* tofile, int value) |
---|
[1901] | 238 | { |
---|
[5656] | 239 | listvar *parcours; |
---|
[1901] | 240 | |
---|
[5656] | 241 | parcours = List_FunctionType_Var; |
---|
| 242 | while ( parcours ) |
---|
| 243 | { |
---|
[10088] | 244 | if (!strcmp(parcours->var->v_typevar, "")) |
---|
| 245 | { |
---|
| 246 | /* Default type*/ |
---|
| 247 | if ( IsVariableReal(parcours->var->v_nomvar) == 1 ) |
---|
| 248 | strcpy(parcours->var->v_typevar,"REAL"); |
---|
| 249 | else strcpy(parcours->var->v_typevar,"INTEGER"); |
---|
| 250 | } |
---|
[5656] | 251 | if ( !strcasecmp(parcours->var->v_subroutinename, subroutinename) && |
---|
| 252 | strcasecmp(parcours->var->v_typevar, "") ) |
---|
| 253 | { |
---|
| 254 | WriteVarDeclaration(parcours->var, tofile, value, 1); |
---|
| 255 | } |
---|
| 256 | parcours = parcours -> suiv; |
---|
| 257 | } |
---|
[1901] | 258 | } |
---|
| 259 | |
---|
| 260 | void WriteSubroutineDeclaration(int value) |
---|
| 261 | { |
---|
[5656] | 262 | listvar *parcours; |
---|
| 263 | variable *v; |
---|
[1901] | 264 | |
---|
[5656] | 265 | parcours = List_SubroutineDeclaration_Var; |
---|
| 266 | while ( parcours ) |
---|
| 267 | { |
---|
| 268 | v = parcours->var; |
---|
| 269 | if ( !strcasecmp(v->v_subroutinename, subroutinename) && |
---|
| 270 | (v->v_save == 0) && |
---|
| 271 | (v->v_VariableIsParameter == 0) && |
---|
| 272 | (v->v_common == 0) ) |
---|
| 273 | { |
---|
| 274 | WriteVarDeclaration(v, fortran_out, value, 1); |
---|
| 275 | } |
---|
| 276 | else if ( !strcasecmp(v->v_subroutinename, subroutinename) && |
---|
| 277 | (v->v_save == 0) && |
---|
| 278 | (v->v_VariableIsParameter == 0) && |
---|
| 279 | (v->v_common == 0) ) |
---|
| 280 | { |
---|
| 281 | WriteVarDeclaration(v, fortran_out, value, 1); |
---|
| 282 | } |
---|
| 283 | parcours = parcours -> suiv; |
---|
| 284 | } |
---|
[1901] | 285 | } |
---|
| 286 | |
---|
| 287 | void WriteArgumentDeclaration_beforecall() |
---|
| 288 | { |
---|
[5656] | 289 | int position; |
---|
| 290 | listnom *neededparameter; |
---|
| 291 | FILE *paramtoamr; |
---|
| 292 | listvar *parcours; |
---|
| 293 | variable *v; |
---|
[10088] | 294 | char *ligne; |
---|
| 295 | size_t line_length; |
---|
| 296 | int res; |
---|
| 297 | int global_check; |
---|
[1901] | 298 | |
---|
[10088] | 299 | ligne = (char*) calloc(LONG_M, sizeof(char)); |
---|
| 300 | line_length = LONG_M; |
---|
| 301 | |
---|
| 302 | global_check = 0; |
---|
| 303 | |
---|
| 304 | |
---|
[5656] | 305 | fprintf(fortran_out,"#include \"Param_BeforeCall_%s.h\"\n",subroutinename); |
---|
[1901] | 306 | |
---|
[5656] | 307 | sprintf(ligne,"Param_BeforeCall_%s.h",subroutinename); |
---|
| 308 | paramtoamr = open_for_write(ligne); |
---|
[1901] | 309 | |
---|
[5656] | 310 | neededparameter = (listnom * )NULL; |
---|
| 311 | position = 1; |
---|
| 312 | parcours = List_SubroutineArgument_Var; |
---|
| 313 | |
---|
| 314 | while ( parcours ) |
---|
| 315 | { |
---|
| 316 | v = parcours->var; |
---|
| 317 | if ( !strcasecmp(v->v_subroutinename, subroutinename) && (v->v_positioninblock == position) ) |
---|
| 318 | { |
---|
| 319 | position++; |
---|
| 320 | WriteVarDeclaration(v, fortran_out, 0, 1); |
---|
[10088] | 321 | res = writedeclarationintoamr(List_Parameter_Var, paramtoamr, |
---|
| 322 | v, v->v_subroutinename, &neededparameter, subroutinename, global_check); |
---|
[5656] | 323 | parcours = List_SubroutineArgument_Var; |
---|
| 324 | } |
---|
| 325 | else parcours = parcours -> suiv; |
---|
| 326 | } |
---|
| 327 | |
---|
| 328 | // Write interface for 'Sub_Loop_machin' in 'Param_BeforeCall_machin.h' when outside a module |
---|
| 329 | if ( IsTabvarsUseInArgument_0() && (inmodulemeet == 0) && (inprogramdeclare == 0) ) |
---|
| 330 | { |
---|
| 331 | fprintf(paramtoamr, " interface\n"); |
---|
| 332 | if (isrecursive) sprintf(ligne," recursive subroutine Sub_Loop_%s(", subroutinename); |
---|
| 333 | else sprintf(ligne," subroutine Sub_Loop_%s(", subroutinename); |
---|
[10088] | 334 | WriteVariablelist_subloop(&ligne,&line_length); |
---|
| 335 | WriteVariablelist_subloop_Def(&ligne,&line_length); |
---|
[5656] | 336 | strcat(ligne,")"); |
---|
[10088] | 337 | |
---|
[5656] | 338 | tofich(paramtoamr,ligne,1); |
---|
| 339 | |
---|
| 340 | listusemodule *parcours_mod; |
---|
| 341 | parcours_mod = List_NameOfModuleUsed; |
---|
| 342 | while ( parcours_mod ) |
---|
| 343 | { |
---|
| 344 | if ( !strcasecmp(parcours_mod->u_cursubroutine, subroutinename) ) |
---|
| 345 | { |
---|
| 346 | fprintf(paramtoamr, " use %s\n", parcours_mod->u_usemodule); |
---|
| 347 | } |
---|
| 348 | parcours_mod = parcours_mod->suiv; |
---|
| 349 | } |
---|
| 350 | fprintf(paramtoamr, " implicit none\n"); |
---|
| 351 | WriteLocalParamDeclaration(paramtoamr); |
---|
| 352 | writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var, paramtoamr); |
---|
| 353 | writesub_loopdeclaration_tab(List_UsedInSubroutine_Var, paramtoamr); |
---|
| 354 | WriteArgumentDeclaration_Sort(paramtoamr); |
---|
| 355 | WriteFunctionDeclaration(paramtoamr, 1); |
---|
| 356 | |
---|
| 357 | sprintf(ligne," end subroutine Sub_Loop_%s\n", subroutinename); |
---|
| 358 | tofich(paramtoamr, ligne, 1); |
---|
| 359 | fprintf(paramtoamr, " end interface\n"); |
---|
| 360 | } |
---|
| 361 | fclose(paramtoamr); |
---|
[1901] | 362 | } |
---|
| 363 | |
---|
[5656] | 364 | void WriteArgumentDeclaration_Sort(FILE* tofile) |
---|
[1901] | 365 | { |
---|
[5656] | 366 | int position = 1; |
---|
| 367 | listvar *parcours; |
---|
[1901] | 368 | |
---|
[5656] | 369 | parcours = List_SubroutineArgument_Var; |
---|
[10088] | 370 | |
---|
[5656] | 371 | while ( parcours ) |
---|
| 372 | { |
---|
| 373 | if ( !strcasecmp(parcours->var->v_subroutinename, subroutinename) && |
---|
| 374 | parcours->var->v_positioninblock == position ) |
---|
| 375 | { |
---|
| 376 | position = position + 1; |
---|
| 377 | WriteVarDeclaration(parcours->var, tofile, 1, 1); |
---|
| 378 | parcours = List_SubroutineArgument_Var; |
---|
| 379 | } |
---|
| 380 | else parcours = parcours -> suiv; |
---|
| 381 | } |
---|
[1901] | 382 | |
---|
[5656] | 383 | parcours = List_SubroutineArgument_Var; |
---|
| 384 | while ( parcours ) |
---|
| 385 | { |
---|
| 386 | if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) && |
---|
| 387 | parcours->var->v_positioninblock == 0 && |
---|
| 388 | parcours->var->v_nbdim == 0 ) |
---|
| 389 | { |
---|
| 390 | WriteVarDeclaration(parcours->var,tofile,1,1); |
---|
| 391 | } |
---|
| 392 | parcours = parcours -> suiv; |
---|
| 393 | } |
---|
[1901] | 394 | |
---|
[5656] | 395 | parcours = List_SubroutineArgument_Var; |
---|
| 396 | while ( parcours ) |
---|
| 397 | { |
---|
| 398 | if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) && |
---|
| 399 | parcours->var->v_positioninblock == 0 && |
---|
| 400 | parcours->var->v_nbdim != 0 ) |
---|
| 401 | { |
---|
| 402 | WriteVarDeclaration(parcours->var, tofile, 1, 1); |
---|
| 403 | } |
---|
| 404 | parcours = parcours -> suiv; |
---|
| 405 | } |
---|
[1901] | 406 | } |
---|
| 407 | |
---|
| 408 | /******************************************************************************/ |
---|
| 409 | /* writedeclarationintoamr */ |
---|
| 410 | /******************************************************************************/ |
---|
| 411 | /* This subroutine is used to write the declaration of parameters needed in */ |
---|
| 412 | /* allocation subroutines creates in toamr.c */ |
---|
| 413 | /******************************************************************************/ |
---|
| 414 | /* */ |
---|
| 415 | /* */ |
---|
| 416 | /******************************************************************************/ |
---|
[10088] | 417 | int writedeclarationintoamr (listvar * deb_common, FILE *fileout, |
---|
[5656] | 418 | variable *var , const char *commonname, |
---|
[10088] | 419 | listnom **neededparameter, const char *name_common, int global_check) |
---|
[1901] | 420 | { |
---|
| 421 | listvar *newvar; |
---|
| 422 | variable *v; |
---|
[5656] | 423 | char ligne[LONG_M]; |
---|
[1901] | 424 | int changeval; |
---|
| 425 | int out; |
---|
| 426 | int writeit; |
---|
| 427 | listnom *parcours; |
---|
[10088] | 428 | listname *parcours_name_array; |
---|
| 429 | int res; |
---|
| 430 | |
---|
| 431 | res = 0; |
---|
[1901] | 432 | |
---|
| 433 | /* we should list the needed parameter */ |
---|
[10088] | 434 | |
---|
[1901] | 435 | if ( !strcasecmp(name_common,commonname) ) |
---|
[10088] | 436 | { |
---|
| 437 | *neededparameter = DecomposeTheNameinlistnom(var->v_readedlistdimension,*neededparameter); |
---|
| 438 | parcours_name_array = var->v_initialvalue_array; |
---|
| 439 | while (parcours_name_array) |
---|
| 440 | { |
---|
| 441 | *neededparameter = DecomposeTheNameinlistnom(parcours_name_array->n_name,*neededparameter); |
---|
| 442 | parcours_name_array=parcours_name_array->suiv; |
---|
| 443 | } |
---|
| 444 | } |
---|
| 445 | |
---|
[1901] | 446 | /* */ |
---|
[10088] | 447 | parcours = *neededparameter; |
---|
| 448 | |
---|
[1901] | 449 | while (parcours) |
---|
| 450 | { |
---|
| 451 | newvar = deb_common; |
---|
[2715] | 452 | |
---|
[1901] | 453 | out = 0 ; |
---|
| 454 | while ( newvar && out == 0 ) |
---|
| 455 | { |
---|
[10088] | 456 | if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename)) |
---|
[1901] | 457 | { |
---|
| 458 | out=1; |
---|
| 459 | /* add the name to the list of needed parameter */ |
---|
[10088] | 460 | *neededparameter = DecomposeTheNameinlistnom( |
---|
| 461 | newvar->var->v_initialvalue->n_name, |
---|
| 462 | *neededparameter ); |
---|
[1901] | 463 | } |
---|
[10088] | 464 | else if ( (global_check == 1) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_modulename,newvar->var->v_modulename)) |
---|
| 465 | { |
---|
| 466 | out=1; |
---|
| 467 | /* add the name to the list of needed parameter */ |
---|
| 468 | *neededparameter = DecomposeTheNameinlistnom( |
---|
| 469 | newvar->var->v_initialvalue->n_name, |
---|
| 470 | *neededparameter ); |
---|
| 471 | } |
---|
[1901] | 472 | else newvar=newvar->suiv; |
---|
| 473 | } |
---|
| 474 | parcours=parcours->suiv; |
---|
| 475 | } |
---|
| 476 | /* */ |
---|
[10088] | 477 | parcours = *neededparameter; |
---|
| 478 | |
---|
[1901] | 479 | while (parcours) |
---|
| 480 | { |
---|
| 481 | newvar = deb_common; |
---|
| 482 | out = 0 ; |
---|
| 483 | while ( newvar && out == 0 ) |
---|
| 484 | { |
---|
[10088] | 485 | if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename)) |
---|
[1901] | 486 | { |
---|
| 487 | out=1; |
---|
| 488 | /* add the name to the list of needed parameter */ |
---|
[10088] | 489 | *neededparameter = DecomposeTheNameinlistnom( |
---|
| 490 | newvar->var->v_initialvalue->n_name, |
---|
| 491 | *neededparameter ); |
---|
[1901] | 492 | } |
---|
[10088] | 493 | else if ( (global_check == 1) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_modulename,newvar->var->v_modulename)) |
---|
| 494 | { |
---|
| 495 | out=1; |
---|
| 496 | /* add the name to the list of needed parameter */ |
---|
| 497 | *neededparameter = DecomposeTheNameinlistnom( |
---|
| 498 | newvar->var->v_initialvalue->n_name, |
---|
| 499 | *neededparameter ); |
---|
| 500 | } |
---|
[1901] | 501 | else newvar=newvar->suiv; |
---|
| 502 | } |
---|
| 503 | parcours=parcours->suiv; |
---|
| 504 | } |
---|
[10088] | 505 | parcours = *neededparameter; |
---|
[1901] | 506 | while (parcours) |
---|
| 507 | { |
---|
| 508 | writeit = 0; |
---|
| 509 | newvar = deb_common; |
---|
| 510 | while ( newvar && writeit == 0 ) |
---|
| 511 | { |
---|
[10088] | 512 | if ( (global_check == 0) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && |
---|
[2715] | 513 | !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename) && parcours->o_val == 0 ) |
---|
[1901] | 514 | { |
---|
| 515 | writeit=1; |
---|
| 516 | parcours->o_val = 1; |
---|
| 517 | } |
---|
[10088] | 518 | else if ( (global_check == 1) && !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && |
---|
| 519 | !strcasecmp(var->v_modulename,newvar->var->v_modulename) && parcours->o_val == 0 ) |
---|
| 520 | { |
---|
| 521 | writeit=1; |
---|
| 522 | parcours->o_val = 1; |
---|
| 523 | } |
---|
[1901] | 524 | else newvar = newvar->suiv; |
---|
| 525 | } |
---|
| 526 | |
---|
| 527 | if ( writeit == 1 ) |
---|
| 528 | { |
---|
| 529 | changeval = 0; |
---|
| 530 | v = newvar->var; |
---|
[2715] | 531 | // if ( v->v_allocatable == 1 && strcasecmp(v->v_typevar,"type") ) |
---|
| 532 | // { |
---|
| 533 | // changeval = 1; |
---|
| 534 | // v->v_allocatable = 0; |
---|
| 535 | // } |
---|
[5656] | 536 | WriteBeginDeclaration(v, ligne, 1); |
---|
[1901] | 537 | if ( v->v_nbdim == 0 ) WriteScalarDeclaration(v,ligne); |
---|
[5656] | 538 | else WriteTableDeclaration(v, ligne, 1); |
---|
[1901] | 539 | |
---|
[5656] | 540 | tofich(fileout, ligne, 1); |
---|
[1901] | 541 | if ( changeval == 1 ) |
---|
| 542 | { |
---|
| 543 | v->v_allocatable = 1; |
---|
| 544 | } |
---|
[10088] | 545 | res = 1; |
---|
[1901] | 546 | } |
---|
| 547 | else |
---|
| 548 | { |
---|
| 549 | if ( strncasecmp(parcours->o_nom,"mpi_",4) == 0 && |
---|
| 550 | shouldincludempif == 1 ) |
---|
| 551 | { |
---|
| 552 | shouldincludempif = 0; |
---|
[5656] | 553 | fprintf(fileout," include \'mpif.h\'\n"); |
---|
[1901] | 554 | } |
---|
| 555 | } |
---|
| 556 | parcours=parcours->suiv; |
---|
| 557 | } |
---|
| 558 | Save_Length(ligne,45); |
---|
[10088] | 559 | return res; |
---|
[1901] | 560 | } |
---|
| 561 | |
---|
| 562 | |
---|
| 563 | /******************************************************************************/ |
---|
| 564 | /* writesub_loopdeclaration_scalar */ |
---|
| 565 | /******************************************************************************/ |
---|
| 566 | /* This subroutine is used to write the declaration part of subloop */ |
---|
| 567 | /* subroutines */ |
---|
| 568 | /******************************************************************************/ |
---|
| 569 | /* */ |
---|
| 570 | /* integer variable(nb) -----------> */ |
---|
| 571 | /* */ |
---|
| 572 | /* INTEGER, DIMENSION(1:nb) :: variable */ |
---|
| 573 | /* */ |
---|
| 574 | /******************************************************************************/ |
---|
| 575 | void writesub_loopdeclaration_scalar (listvar * deb_common, FILE *fileout) |
---|
| 576 | { |
---|
| 577 | listvar *newvar; |
---|
| 578 | variable *v; |
---|
[5656] | 579 | char ligne[LONG_M]; |
---|
[1901] | 580 | |
---|
[5656] | 581 | // tofich (fileout, "",1); |
---|
[1901] | 582 | newvar = deb_common; |
---|
[2715] | 583 | |
---|
[1901] | 584 | while (newvar) |
---|
| 585 | { |
---|
| 586 | if ( newvar->var->v_nbdim == 0 && |
---|
| 587 | !strcasecmp(newvar->var->v_subroutinename,subroutinename) && |
---|
[10088] | 588 | (newvar->var->v_pointerdeclare >= 0 || !strcasecmp(newvar->var->v_typevar,"type")) ) |
---|
[1901] | 589 | { |
---|
| 590 | v = newvar->var; |
---|
| 591 | WriteBeginDeclaration(v,ligne,1); |
---|
| 592 | WriteScalarDeclaration(v,ligne); |
---|
| 593 | tofich (fileout, ligne,1); |
---|
| 594 | } |
---|
| 595 | newvar = newvar->suiv; |
---|
| 596 | } |
---|
| 597 | Save_Length(ligne,45); |
---|
| 598 | } |
---|
| 599 | |
---|
| 600 | /******************************************************************************/ |
---|
| 601 | /* writesub_loopdeclaration_tab */ |
---|
| 602 | /******************************************************************************/ |
---|
| 603 | /* This subroutine is used to write the declaration part of subloop */ |
---|
| 604 | /* subroutines */ |
---|
| 605 | /******************************************************************************/ |
---|
| 606 | /* */ |
---|
| 607 | /* integer variable(nb) -----------> */ |
---|
| 608 | /* */ |
---|
| 609 | /* INTEGER, DIMENSION(1:nb) :: variable */ |
---|
| 610 | /* */ |
---|
| 611 | /******************************************************************************/ |
---|
| 612 | void writesub_loopdeclaration_tab (listvar * deb_common, FILE *fileout) |
---|
| 613 | { |
---|
| 614 | listvar *newvar; |
---|
| 615 | variable *v; |
---|
[5656] | 616 | char ligne[LONG_M]; |
---|
[1901] | 617 | int changeval; |
---|
| 618 | |
---|
| 619 | newvar = deb_common; |
---|
| 620 | while (newvar) |
---|
| 621 | { |
---|
[5656] | 622 | v = newvar->var; |
---|
| 623 | // printf("newvar = %s %d %s\n",newvar->var->v_nomvar,newvar->var->v_pointerdeclare,newvar->var->v_typevar); |
---|
| 624 | if ( (v->v_nbdim != 0) && !strcasecmp(v->v_subroutinename, subroutinename) && |
---|
[10088] | 625 | (v->v_pointerdeclare >= 0 || !strcasecmp(v->v_typevar,"type")) ) |
---|
[1901] | 626 | { |
---|
| 627 | changeval = 0; |
---|
| 628 | if ( v->v_allocatable == 1) |
---|
| 629 | { |
---|
| 630 | if (strcasecmp(v->v_typevar,"type")) |
---|
| 631 | { |
---|
[2715] | 632 | // changeval = 1; |
---|
| 633 | // v->v_allocatable = 0; |
---|
[1901] | 634 | } |
---|
| 635 | else |
---|
| 636 | { |
---|
| 637 | changeval = 2; |
---|
| 638 | v->v_allocatable = 0; |
---|
| 639 | v->v_pointerdeclare = 1; |
---|
| 640 | } |
---|
| 641 | } |
---|
| 642 | |
---|
[5656] | 643 | WriteBeginDeclaration(v, ligne, 1); |
---|
| 644 | WriteTableDeclaration(v, ligne, 1); |
---|
[1901] | 645 | tofich (fileout, ligne,1); |
---|
| 646 | if ( changeval >= 1 ) v->v_allocatable = 1; |
---|
| 647 | if ( changeval == 2 ) v->v_pointerdeclare = 0; |
---|
| 648 | } |
---|
| 649 | newvar = newvar->suiv; |
---|
| 650 | } |
---|
[10088] | 651 | |
---|
[1901] | 652 | Save_Length(ligne,45); |
---|
| 653 | } |
---|
| 654 | |
---|
| 655 | void ReWriteDeclarationAndAddTosubroutine_01(listvar *listdecl) |
---|
| 656 | { |
---|
[5656] | 657 | listvar *parcours; |
---|
| 658 | variable *v; |
---|
| 659 | int out; |
---|
[1901] | 660 | |
---|
[5656] | 661 | if ( insubroutinedeclare ) |
---|
| 662 | { |
---|
| 663 | parcours = listdecl; |
---|
| 664 | while ( parcours ) |
---|
| 665 | { |
---|
| 666 | v = parcours->var; |
---|
| 667 | out = LookingForVariableInList(List_SubroutineArgument_Var, v); |
---|
| 668 | if (out == 0) out = VariableIsInListCommon(parcours, List_Common_Var); |
---|
| 669 | if (out == 0) out = LookingForVariableInList(List_Parameter_Var, v); |
---|
| 670 | if (out == 0) out = LookingForVariableInList(List_FunctionType_Var, v); |
---|
| 671 | if (out == 0) out = LookingForVariableInListGlobal(List_Global_Var, v); |
---|
[2715] | 672 | |
---|
[5656] | 673 | if (firstpass == 0 && out == 0 && VariableIsParameter == 0 && SaveDeclare == 0) |
---|
| 674 | { |
---|
[10088] | 675 | |
---|
| 676 | /* The type may has not been given if the variable was only declared with dimension */ |
---|
| 677 | |
---|
| 678 | if ( !strcasecmp(v->v_typevar,"") ) |
---|
| 679 | { |
---|
| 680 | if ( IsVariableReal(v->v_nomvar) == 1 ) |
---|
| 681 | strcpy(v->v_typevar,"REAL"); |
---|
| 682 | else strcpy(v->v_typevar,"INTEGER"); |
---|
| 683 | v->v_catvar = get_cat_var(v); |
---|
| 684 | } |
---|
| 685 | |
---|
[5656] | 686 | WriteVarDeclaration(v, fortran_out, 1, 1); |
---|
| 687 | } |
---|
| 688 | if (firstpass == 1) |
---|
| 689 | { |
---|
| 690 | if (VariableIsParameter == 0 && SaveDeclare == 0) |
---|
| 691 | { |
---|
| 692 | List_SubroutineDeclaration_Var = insertvar(List_SubroutineDeclaration_Var, v); |
---|
| 693 | } |
---|
| 694 | } |
---|
| 695 | parcours = parcours->suiv; |
---|
| 696 | } |
---|
[1901] | 697 | } |
---|
| 698 | } |
---|
[2715] | 699 | |
---|
| 700 | void ReWriteDataStatement_0(FILE * filout) |
---|
| 701 | { |
---|
[5656] | 702 | listvar *parcours; |
---|
| 703 | int out; |
---|
| 704 | char ligne[LONG_M]; |
---|
| 705 | char initialvalue[LONG_M]; |
---|
[10088] | 706 | listname *parcours_name; |
---|
| 707 | |
---|
[5656] | 708 | if (insubroutinedeclare == 1) |
---|
| 709 | { |
---|
| 710 | parcours = List_Data_Var_Cur ; |
---|
| 711 | while (parcours) |
---|
| 712 | { |
---|
| 713 | out = VariableIsInListCommon(parcours,List_Common_Var); |
---|
| 714 | if (out) break; |
---|
[2715] | 715 | |
---|
[5656] | 716 | out = LookingForVariableInListGlobal(List_Global_Var,parcours->var); |
---|
| 717 | if (out) break; |
---|
| 718 | |
---|
[10088] | 719 | strcpy(initialvalue,""); |
---|
| 720 | parcours_name = parcours->var->v_initialvalue; |
---|
| 721 | while (parcours_name) |
---|
[5656] | 722 | { |
---|
[10088] | 723 | if (strncasecmp(parcours_name->n_name,"(/",2)) |
---|
| 724 | { |
---|
| 725 | strcat(initialvalue,parcours_name->n_name); |
---|
| 726 | if (parcours_name->suiv) |
---|
| 727 | { |
---|
| 728 | strcat(initialvalue,","); |
---|
| 729 | } |
---|
[5656] | 730 | } |
---|
| 731 | else |
---|
| 732 | { |
---|
[10088] | 733 | printf("A TRAITER DANS REWRITEDATA STATEMETN "); |
---|
| 734 | exit(1); |
---|
| 735 | strncpy(initialvalue,&parcours_name->n_name[2],strlen(parcours_name->n_name)-4); |
---|
| 736 | strcpy(&initialvalue[strlen(parcours_name->n_name)-4],"\0"); |
---|
[5656] | 737 | } |
---|
[10088] | 738 | parcours_name=parcours_name->suiv; |
---|
| 739 | } |
---|
[5656] | 740 | sprintf(ligne,"data %s/%s/",parcours->var->v_nomvar,initialvalue); |
---|
| 741 | tofich(filout,ligne,1); |
---|
[10088] | 742 | |
---|
[5656] | 743 | parcours = parcours->suiv; |
---|
| 744 | } |
---|
| 745 | } |
---|
[2715] | 746 | } |
---|