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