void WriteHeadofSubroutineLoop()
{
char ligne[LONG_40M];
FILE * subloop;
if ( todebug == 1 ) printf("Enter in WriteHeadofSubroutineLoop\n");
tofich(fortranout,"\n",1);
/* Open this newfile */
sprintf(ligne,"Sub_Loop_%s.h",subroutinename);
subloop = associate(ligne);
/* */
if (isrecursive)
{
sprintf(ligne," recursive subroutine Sub_Loop_%s(",subroutinename);
}
else
{
sprintf(ligne," subroutine Sub_Loop_%s(",subroutinename);
}
/* */
WriteVariablelist_subloop(subloop,ligne);
WriteVariablelist_subloop_Def(subloop,ligne);
/* */
strcat(ligne,")");
tofich(subloop,ligne,1);
/* if USE agrif_Uti l should be add */
AddUseAgrifUtil_0(subloop);
/* */
oldfortranout = fortranout;
fortranout = subloop;
if ( todebug == 1 ) printf("Out of WriteHeadofSubroutineLoop\n");
}
void write_Getnumberofcells_file(char *name)
{
char ligne[LONG_C];
FILE *getnumberofcells;
if ( IndicenbmaillesX != 0 )
{
getnumberofcells=associate(name);
sprintf (ligne,
"Agrif_Curgrid %% tabvars(%d) %% var %% iarray0 = Agrif_Gr %% nb(1)",
IndicenbmaillesX);
tofich (getnumberofcells, ligne,1);
if (dimprob > 1)
{
sprintf (ligne,
"Agrif_Curgrid %% tabvars(%d) %% var %% iarray0 = Agrif_Gr %% nb(2)",
IndicenbmaillesY);
tofich (getnumberofcells, ligne,1);
}
if (dimprob > 2)
{
sprintf (ligne,
"Agrif_Curgrid %% tabvars(%d) %% var %% iarray0 = Agrif_Gr %% nb(3)",
IndicenbmaillesZ);
tofich (getnumberofcells, ligne,1);
}
fclose (getnumberofcells);
}
}
void write_Setnumberofcells_file(char *name)
{
char ligne[LONG_C];
FILE *setnumberofcells;
if ( IndicenbmaillesX != 0 )
{
setnumberofcells=associate(name);
if (onlyfixedgrids != 1 )
{
sprintf (ligne,
"Agrif_Gr %% nb(1) = Agrif_Gr %% tabvars(%d) %% var %% iarray0",
IndicenbmaillesX);
}
else
{
sprintf (ligne,
"Agrif_Gr %% nb(1) = Agrif_Curgrid %% tabvars(%d) %% var %% iarray0",
IndicenbmaillesX);
}
tofich (setnumberofcells, ligne,1);
if (dimprob > 1)
{
if (onlyfixedgrids != 1 )
{
sprintf (ligne,
"Agrif_Gr %% nb(2) = Agrif_Gr %% tabvars(%d) %% var %% iarray0",
IndicenbmaillesY);
}
else
{
sprintf (ligne,
"Agrif_Gr %% nb(2) = Agrif_Curgrid %% tabvars(%d) %% var %% iarray0",
IndicenbmaillesY);
}
tofich (setnumberofcells, ligne,1);
}
if (dimprob > 2)
{
if (onlyfixedgrids != 1 )
{
sprintf (ligne,
"Agrif_Gr %% nb(3) = Agrif_Gr %% tabvars(%d) %% var %% iarray0",
IndicenbmaillesZ);
}
else
{
sprintf (ligne,
"Agrif_Gr %% nb(3) = Agrif_Curgrid %% tabvars(%d) %% var %% iarray0",
IndicenbmaillesZ);
}
tofich (setnumberofcells, ligne,1);
}
fclose (setnumberofcells);
}
}
void closeandcallsubloopandincludeit_0(int suborfun)
{
char ligne[LONG_40M];
if ( firstpass == 0 )
{
if ( todebug == 1 ) printf("Enter in closeandcallsubloopandincludeit_0\n");
if ( IsTabvarsUseInArgument_0() == 1 )
{
/* We should remove the key word end subroutine */
RemoveWordCUR_0(fortranout,(long)(-(pos_cur-pos_endsubroutine)),
pos_cur-pos_endsubroutine);
/* We should close the loop subroutine */
sprintf(ligne,"\n end subroutine Sub_Loop_%s",subroutinename);
tofich(fortranout,ligne,1);
fclose(fortranout);
fortranout = oldfortranout;
AddUseAgrifUtilBeforeCall_0(fortranout);
if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(0);
WriteArgumentDeclaration_beforecall();
if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
fprintf(oldfortranout," Call Agrif_Init_Grids () \n");
/* Now we add the call af the new subroutine */
sprintf(ligne,"\n Call Sub_Loop_%s( ",subroutinename);
/* Write the list of the local variables used in this new subroutine */
WriteVariablelist_subloop(fortranout,ligne);
/* Write the list of the global tables used in this new subroutine */
/* in doloop */
WriteVariablelist_subloop_Call(fortranout,ligne);
/* Close the parenthesis of the new subroutine called */
strcat(ligne,")");
tofich(fortranout,ligne,1);
/* We should close the original subroutine */
if ( suborfun == 3 ) sprintf(ligne,"\n end program %s"
,subroutinename);
if ( suborfun == 2 ) sprintf(ligne,"\n end");
if ( suborfun == 1 ) sprintf(ligne,"\n end subroutine %s"
,subroutinename);
if ( suborfun == 0 ) sprintf(ligne,"\n end function %s"
,subroutinename);
tofich(fortranout,ligne,1);
/* we should include the above file in the original code */
sprintf(ligne,"\n#include \"Sub_Loop_%s.h\" \n",subroutinename);
tofich(fortranout,ligne,1);
}
oldfortranout = (FILE *)NULL;
if ( todebug == 1 ) printf("Out of closeandcallsubloopandincludeit_0\n");
}
}
void closeandcallsubloop_contains_0()
{
char ligne[LONG_40M];
if ( firstpass == 0 )
{
if ( todebug == 1 ) printf("Enter in closeandcallsubloopandincludeit_0\n");
if ( IsTabvarsUseInArgument_0() == 1 )
{
Remove_Word_Contains_0();
sprintf(ligne,"\n end subroutine Sub_Loop_%s",subroutinename);
tofich(fortranout,ligne,1);
fclose(fortranout);
fortranout = oldfortranout;
AddUseAgrifUtilBeforeCall_0(fortranout);
if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
" IMPLICIT NONE\n");
WriteLocalParamDeclaration();
if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(0);
WriteArgumentDeclaration_beforecall();
WriteSubroutineDeclaration(0);
if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
fprintf(oldfortranout," Call Agrif_Init_Grids () \n");
/* Now we add the call af the new subroutine */
if ( retour77 == 0 ) sprintf(ligne,"\n Call Sub_Loop_%s( &"
,subroutinename);
else sprintf(ligne,"\n Call Sub_Loop_%s( ",subroutinename);
fprintf(fortranout,ligne);
/* Write the list of the local variables used in this new subroutine */
WriteVariablelist_subloop(fortranout,ligne);
/* Write the list of the global tables used in this new subroutine */
/* in doloop */
WriteVariablelist_subloop_Call(fortranout,ligne);
/* Close the parenthesis of the new subroutine called */
sprintf(ligne,")");
tofich(fortranout,ligne,1);
/* We should close the original subroutine */
sprintf(ligne,"\n contains");
tofich(fortranout,ligne,1);
/* we should include the above file in the original code */
sprintf(ligne,"\n#include \"Sub_Loop_%s.h\" \n",subroutinename);
tofich(fortranout,ligne,1);
}
oldfortranout = (FILE *)NULL;
if ( todebug == 1 ) printf("Out of closeandcallsubloopandincludeit_0\n");
}
}
void write_probdimagrif_file()
{
FILE *probdim;
char ligne[LONG_C];
probdim = associate("probdim_agrif.h");
sprintf (ligne, "Agrif_Probdim = %d", dimprob);
tofich (probdim, ligne,1);
fclose (probdim);
}
void write_modtypeagrif_file()
{
char ligne[LONG_C];
FILE *typedata;
typedata = associate ("modtype_agrif.h");
/* AGRIF_NbVariables : number of variables */
sprintf (ligne, "AGRIF_NbVariables = %d",indicemaxtabvars);
tofich(typedata,ligne,1);
fclose (typedata);
}
void write_createvarnameagrif_file(variable *v,FILE *createvarname,
int *InitEmpty)
{
char ligne[LONG_C];
char *tmp;
char temp1[LONG_C];
tmp = variablenametabvars(v,0);
strcpy (temp1, tmp);
if ( todebugfree == 1 ) free(tmp);
*InitEmpty = 0 ;
sprintf(ligne, "%s %% namevar = \"%s\"",temp1,v->v_nomvar);
tofich(createvarname,ligne,1);
}
void write_initialisationsagrif_file(variable *v,FILE *initproc,
int *VarnameEmpty)
{
char ligne[LONG_C];
char temp1[LONG_C];
char *tmp;
tmp = variablenameroottabvars (v);
strcpy (temp1, tmp);
if ( todebugfree == 1 ) free(tmp);
if ( v->v_nbdim != 0 )
{
*VarnameEmpty = 0 ;
sprintf (ligne, "%s %% nbdim = %d", temp1, v->v_nbdim);
tofich (initproc, ligne,1);
}
}
void writelistpublic(listname *lin)
{
listname *parcours1;
char ligne[LONG_M];
if (lin)
{
sprintf(ligne,"public :: ");
parcours1 = lin;
while ( parcours1 )
{
strcat(ligne, parcours1->n_name);
if ( parcours1->suiv ) strcat(ligne,", ");
parcours1 = parcours1->suiv;
}
tofich(fortran_out,ligne,1);
}
}
void write_allocation_Global_0()
{
listnom *parcours_nom;
listvar *parcours;
listvar *parcoursprec;
listvar *parcours1;
FILE *allocationagrif;
char ligne[LONGNOM];
variable *v;
int IndiceMax;
int IndiceMin;
int compteur;
int out;
int indiceprec;
int ValeurMax;
char initialvalue[LONG_4C];
int typeiswritten ;
parcoursprec = (listvar *)NULL;
parcours_nom = List_NameOfModule;
ValeurMax = 2;
while ( parcours_nom )
{
/* */
if ( parcours_nom->o_val == 1 )
{
IndiceMax = 0;
IndiceMin = indicemaxtabvars;
/* Open the file to create the Alloc_agrif subroutine */
sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom);
allocationagrif = associate (ligne);
/* */
if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 )
{
/* add the call to initworkspace */
tofich(allocationagrif,"if ( .NOT. Agrif_Root() ) then ",1);
fprintf(allocationagrif,"#include \"GetNumberofcells.h\" \n");
tofich(allocationagrif,"else ",1);
fprintf(allocationagrif,"#include \"SetNumberofcells.h\" \n");
tofich(allocationagrif,"endif ",1);
tofich(allocationagrif,"Call Agrif_InitWorkspace ",1);
}
typeiswritten = 0;
parcours = List_Global_Var;
while ( parcours )
{
if ( !strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom) &&
parcours->var->v_VariableIsParameter == 0 &&
parcours->var->v_notgrid == 0 &&
!strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom) )
{
/***************************************************************/
/***************************************************************/
/***************************************************************/
v = parcours->var;
IndiceMax = 0;
IndiceMin = indicemaxtabvars;
/* body of the file */
if ( !strcasecmp(v->v_commoninfile,mainfile) )
{
if (onlyfixedgrids != 1 && v->v_nbdim!=0)
{
strcpy (ligne, "If (.not. associated(");
strcat (ligne, vargridnametabvars(v,0));
strcat (ligne, ")) then");
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
}
if ( v->v_allocatable != 1 && ( v->v_dimsempty != 1) )
{
/* ALLOCATION */
if ( v->v_dimension != 0 )
{
if ( v->v_indicetabvars < IndiceMin ||
v->v_indicetabvars > IndiceMax )
{
parcours1 = parcours;
compteur = -1;
out = 0;
indiceprec = parcours->var->v_indicetabvars -1 ;
while ( parcours1 && out == 0 &&
!strcasecmp( parcours->var->v_readedlistdimension,
parcours1->var->v_readedlistdimension) &&
!strcasecmp( parcours->var->v_typevar,
parcours1->var->v_typevar) &&
( parcours1->var->v_indicetabvars == indiceprec+1 )
)
{
if ( !strcasecmp(parcours1->var->v_modulename,
parcours_nom->o_nom) ||
!strcasecmp(parcours1->var->v_commonname,
parcours_nom->o_nom) )
{
compteur = compteur +1 ;
indiceprec = parcours1->var->v_indicetabvars;
parcoursprec = parcours1;
parcours1 = parcours1->suiv;
}
else out = 1;
}
if ( compteur > ValeurMax )
{
fprintf(allocationagrif," DO i = %d , %d\n",
parcours->var->v_indicetabvars,
parcours->var->v_indicetabvars+compteur);
IndiceMin = parcours->var->v_indicetabvars;
IndiceMax = parcours->var->v_indicetabvars+compteur;
strcpy (ligne, "allocate ");
strcat (ligne, "(");
strcat (ligne, vargridnametabvars(v,1));
strcat (ligne, vargridparam(v,0));
strcat (ligne, ")");
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
fprintf(allocationagrif," end do\n");
parcours = parcoursprec;
}
else
{
strcpy (ligne, "allocate ");
strcat (ligne, "(");
strcat (ligne, vargridnametabvars(v,0));
strcat (ligne, vargridparam(v,0));
strcat (ligne, ")");
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
}
}
} /* end of the allocation part */
/* INITIALISATION */
if ( strcasecmp(v->v_initialvalue,"") )
{
strcpy (ligne, "");
strcat (ligne, vargridnametabvars(v,0));
/* We should modify the initialvalue in the case of variable has */
/* been defined with others variables */
strcpy(initialvalue,
ChangeTheInitalvaluebyTabvarsName
(v->v_initialvalue,List_Global_Var,0));
if ( !strcasecmp(initialvalue,v->v_initialvalue) )
{
strcpy(initialvalue,"");
strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
(v->v_initialvalue,List_Common_Var,0));
}
if ( !strcasecmp(initialvalue,v->v_initialvalue) )
{
strcpy(initialvalue,"");
strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
(v->v_initialvalue,List_ModuleUsed_Var,0));
}
strcat (ligne," = ");
strcat (ligne,initialvalue);
/* */
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
}
}
/* Case of structure types */
if ((typeiswritten == 0) && !strcasecmp(v->v_typevar,"type"))
{
sprintf(ligne,"If (.Not.Allocated(Agrif_%s_var)) Then",v->v_modulename);
tofich(allocationagrif, ligne, 1);
sprintf(ligne,"Allocate(Agrif_%s_var(0:Agrif_NbMaxGrids))",v->v_modulename);
tofich(allocationagrif, ligne, 1);
strcpy(ligne,"End If");
tofich(allocationagrif, ligne, 1);
typeiswritten = 1;
}
if (onlyfixedgrids != 1 && v->v_nbdim!=0)
{
strcpy (ligne, " End if");
tofich (allocationagrif, ligne,1);
}
}
/***************************************************************/
/***************************************************************/
/***************************************************************/
}
parcours = parcours -> suiv;
}
/* */
if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 )
{
/* add the call to initworkspace */
tofich(allocationagrif,"if ( .NOT. Agrif_Root() ) then ",1);
fprintf(allocationagrif,"#include \"GetNumberofcells.h\" \n");
tofich(allocationagrif,"else ",1);
fprintf(allocationagrif,"#include \"SetNumberofcells.h\" \n");
tofich(allocationagrif,"endif ",1);
tofich(allocationagrif,"Call Agrif_InitWorkspace ",1);
}
/* Close the file Alloc_agrif */
fclose(allocationagrif);
} /* end parcours_nom == 1 */
/* */
parcours_nom = parcours_nom -> suiv;
}
}
void write_allocation_Common_0()
{
listnom *parcours_nom;
listnom *neededparameter;
listvar *parcours;
listvar *parcoursprec;
listvar *parcours1;
FILE *allocationagrif;
FILE *paramtoamr;
char ligne[LONGNOM];
char ligne2[LONGNOM];
variable *v;
int IndiceMax;
int IndiceMin;
int compteur;
int out;
int indiceprec;
int ValeurMax;
char initialvalue[LONG_4C];
listindice *list_indic;
listindice *parcoursindic;
int i;
parcoursprec = (listvar *)NULL;
parcours_nom = List_NameOfCommon;
ValeurMax = 2;
while ( parcours_nom )
{
/* */
if ( parcours_nom->o_val == 1 )
{
/* Open the file to create the Alloc_agrif subroutine */
sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom);
allocationagrif = associate (ligne);
/* */
fprintf(allocationagrif,"#include \"Param_toamr_%s.h\" \n",
parcours_nom->o_nom);
/* */
sprintf(ligne,"Param_toamr_%s.h",parcours_nom->o_nom);
paramtoamr = associate (ligne);
neededparameter = (listnom * )NULL;
/* */
list_indic = (listindice *)NULL;
/* */
shouldincludempif = 1 ;
parcours = List_Common_Var;
while ( parcours )
{
if ( !strcasecmp(parcours->var->v_commonname,parcours_nom->o_nom) &&
IndiceInlist(parcours->var->v_indicetabvars,list_indic) == 0
)
{
/***************************************************************/
/***************************************************************/
/***************************************************************/
v = parcours->var;
IndiceMax = 0;
IndiceMin = indicemaxtabvars;
/* body of the file */
if ( !strcasecmp(v->v_commoninfile,mainfile) )
{
if (onlyfixedgrids != 1 && v->v_nbdim!=0)
{
strcpy (ligne, "If (.not. associated(");
strcat (ligne, vargridnametabvars(v,0));
strcat (ligne, ")) then");
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
}
if ( v->v_allocatable != 1 && ( v->v_dimsempty != 1) )
{
/* ALLOCATION */
if ( v->v_dimension != 0 )
{
if ( v->v_indicetabvars < IndiceMin ||
v->v_indicetabvars > IndiceMax )
{
parcours1 = parcours;
compteur = -1;
out = 0;
indiceprec = parcours->var->v_indicetabvars -1 ;
while ( parcours1 && out == 0 &&
!strcasecmp( parcours->var->v_readedlistdimension,
parcours1->var->v_readedlistdimension) &&
!strcasecmp( parcours->var->v_typevar,
parcours1->var->v_typevar) &&
( parcours1->var->v_indicetabvars == indiceprec+1 )
)
{
if ( !strcasecmp(parcours1->var->v_modulename,
parcours_nom->o_nom) ||
!strcasecmp(parcours1->var->v_commonname,
parcours_nom->o_nom) )
{
compteur = compteur +1 ;
indiceprec = parcours1->var->v_indicetabvars;
parcoursprec = parcours1;
parcours1 = parcours1->suiv;
}
else out = 1;
}
if ( compteur > ValeurMax )
{
fprintf(allocationagrif," DO i = %d , %d\n",
parcours->var->v_indicetabvars,
parcours->var->v_indicetabvars+compteur);
IndiceMin = parcours->var->v_indicetabvars;
IndiceMax = parcours->var->v_indicetabvars+compteur;
strcpy (ligne, "allocate ");
strcat (ligne, "(");
strcat (ligne, vargridnametabvars(v,1));
strcat (ligne, vargridparam(v,0));
strcat (ligne, ")");
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
fprintf(allocationagrif," end do\n");
i=parcours->var->v_indicetabvars;
do
{
parcoursindic = (listindice *)malloc(sizeof(listindice));
parcoursindic -> i_indice = i;
parcoursindic -> suiv = list_indic;
list_indic = parcoursindic;
i = i + 1;
} while ( i <= parcours->var->v_indicetabvars+compteur );
parcours = parcoursprec;
/* */
}
else
{
strcpy (ligne, "allocate ");
strcat (ligne, "(");
strcat (ligne, vargridnametabvars(v,0));
strcat (ligne, vargridparam(v,0));
strcat (ligne, ")");
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
/* */
parcoursindic = (listindice *)malloc(sizeof(listindice));
parcoursindic -> i_indice = parcours->var->v_indicetabvars;
parcoursindic -> suiv = list_indic;
list_indic = parcoursindic;
}
neededparameter = writedeclarationintoamr(List_Parameter_Var,
paramtoamr,v,parcours_nom->o_nom,neededparameter,
v->v_commonname);
/* */
}
} /* end of the allocation part */
/* INITIALISATION */
if ( strcasecmp(v->v_initialvalue,"") )
{
strcpy (ligne, "");
strcat (ligne, vargridnametabvars(v,0));
/* We should modify the initialvalue in the case of variable has */
/* been defined with others variables */
strcpy(initialvalue,
ChangeTheInitalvaluebyTabvarsName
(v->v_initialvalue,List_Global_Var,0));
if ( !strcasecmp(initialvalue,v->v_initialvalue) )
{
strcpy(initialvalue,"");
strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
(v->v_initialvalue,List_Common_Var,0));
}
if ( !strcasecmp(initialvalue,v->v_initialvalue) )
{
strcpy(initialvalue,"");
strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName
(v->v_initialvalue,List_ModuleUsed_Var,0));
}
strcat (ligne," = ");
if (v->v_nbdim == 0)
{
strcpy(ligne2,initialvalue);
}
else
{
sprintf(ligne2,"RESHAPE(%s,SHAPE(%s))",initialvalue,vargridnametabvars(v,0));
}
strcat (ligne,ligne2);
/* */
Save_Length(ligne,48);
tofich (allocationagrif, ligne,1);
}
}
if (onlyfixedgrids != 1 && v->v_nbdim!=0)
{
strcpy (ligne, " End if");
tofich (allocationagrif, ligne,1);
}
}
/***************************************************************/
/***************************************************************/
/***************************************************************/
}
parcours = parcours -> suiv;
}
/* Close the file Alloc_agrif */
fclose(allocationagrif);
fclose(paramtoamr);
}
/* */
parcours_nom = parcours_nom -> suiv;
}
}
void writeheadnewsub_0()
{
char ligne[LONG_C];
if ( firstpass == 0 && IsTabvarsUseInArgument_0() == 1 )
{
if ( todebug == 1 ) printf("Enter in writeheadnewsub_0\n");
/* we should add the use agrif_uti l if it is necessary */
WriteHeadofSubroutineLoop();
WriteUsemoduleDeclaration(subroutinename);
if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
" IMPLICIT NONE\n");
WriteIncludeDeclaration();
/* */
/* We should write once the declaration of tables (extract */
/* from pointer) in the new subroutine */
if ( mark == 1 ) fprintf(fortranout,"!!! 000000000000000 \n");
if ( SubInList_ContainsSubroutine() == 0 ) WriteLocalParamDeclaration();
if ( mark == 1 ) fprintf(fortranout,"!!! 111111111111111 \n");
sprintf(ligne,"\n#include \"ParamFile%s.h\" \n",subroutinename);
tofich(fortranout,ligne,1);
WriteArgumentDeclaration_Sort();
if ( mark == 1 ) fprintf(fortranout,"!!! 222222222222222 \n");
writesub_loopdeclaration_tab(List_UsedInSubroutine_Var,fortranout);
if ( mark == 1 ) fprintf(fortranout,"!!! 333333333333333 \n");
writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var,paramout);
if ( mark == 1 ) fprintf(fortranout,"!!! 444444444444444 \n");
/* now we should write the function declaration */
/* case if it is the */
WriteFunctionDeclaration(1);
if ( mark == 1 ) fprintf(fortranout,"!!! 555555555555555 \n");
// if ( SubInList_ContainsSubroutine() == 0 ) WriteSubroutineDeclaration(1);
if ( mark == 1 ) fprintf(fortranout,"!!! 666666666666666 \n");
if ( todebug == 1 ) printf("Out of writeheadnewsub_0\n");
}
else if ( firstpass == 0 )
{
AddUseAgrifUtil_0(fortranout);
WriteUsemoduleDeclaration(subroutinename);
WriteIncludeDeclaration();
if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
" IMPLICIT NONE\n");
if ( mark == 1 ) fprintf(fortranout,"!!! aaaaaaaaaaaaaaa \n");
WriteLocalParamDeclaration();
if ( mark == 1 ) fprintf(fortranout,"!!! bbbbbbbbbbbbbbb \n");
if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(1);
if ( mark == 1 ) fprintf(fortranout,"!!! bbbbbbccccccccc \n");
WriteArgumentDeclaration_beforecall();
/* writesub_loopdeclaration_scalar(List_SubroutineArgument_Var,fortranout);
writesub_loopdeclaration_tab(List_SubroutineArgument_Var,fortranout);*/
if ( mark == 1 ) fprintf(fortranout,"!!! ccccccccccccccc \n");
if ( mark == 1 ) fprintf(fortranout,"!!! ddddddddddddddd \n");
// WriteSubroutineDeclaration(1);
if ( mark == 1 ) fprintf(fortranout,"!!! eeeeeeeeeeeeeee \n");
}
}
void Write_Closing_Module(int forend)
{
listvar *parcours;
listnom *parcours_nom;
listnom *parcours_nomprec;
variable *v;
int out = 0;
int headtypewritten = 0;
char ligne[LONG_M];
int changeval;
// Write Global Parameter Declaration
parcours = List_GlobalParameter_Var;
while( parcours )
{
if ( !strcasecmp(parcours->var->v_modulename, curmodulename) )
{
WriteVarDeclaration(parcours->var, module_declar, 0, 1);
}
parcours = parcours -> suiv;
}
// Write Global Type declaration
parcours = List_Global_Var;
while( parcours )
{
v = parcours->var;
if ( !strcasecmp(v->v_modulename, curmodulename) &&
!strcasecmp(v->v_typevar, "type") )
{
if ( headtypewritten == 0 )
{
fprintf(fortran_out, "\n type Agrif_%s\n", curmodulename);
headtypewritten = 1;
}
changeval = 0;
if ( v->v_allocatable )
{
changeval = 1;
v->v_allocatable = 0;
v->v_pointerdeclare = 1;
}
WriteVarDeclaration(v, fortran_out, 0, 0);
if ( changeval )
{
v->v_allocatable = 1;
v->v_pointerdeclare = 0;
}
out = 1;
}
parcours = parcours -> suiv;
}
if (out == 1)
{
fprintf(fortran_out, " end type Agrif_%s\n", curmodulename);
sprintf(ligne, "type(Agrif_%s), dimension(:), allocatable :: Agrif_%s_var",curmodulename, curmodulename);
tofich(fortran_out,ligne,1);
fprintf(fortran_out, " public :: Agrif_%s\n", curmodulename);
fprintf(fortran_out, " public :: Agrif_%s_var\n", curmodulename);
}
// Write NotGridDepend declaration
parcours = List_NotGridDepend_Var;
while( parcours )
{
if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
{
WriteVarDeclaration(parcours->var, fortran_out, 0, 1);
}
parcours = parcours -> suiv;
}
// Write Alloc_agrif_'modulename' subroutine
parcours_nomprec = (listnom*) NULL;
parcours_nom = List_NameOfModule;
out = 0 ;
while ( parcours_nom && out == 0 )
{
if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1;
else parcours_nom = parcours_nom -> suiv;
}
if ( ! out )
{
printf("#\n# Write_Closing_Module : OUT == 0 *** /!\\ ***\n");
printf("# FIXME: POSSIBLE BUG in CONV !!!\n#\n");
}
if ( out )
{
if ( parcours_nom->o_val == 1 )
{
fprintf(fortran_out,"\n public :: Alloc_agrif_%s\n",curmodulename);
}
if ( (forend == 0) || (parcours_nom->o_val == 1) )
{
fprintf(fortran_out,"\n contains\n");
}
if ( parcours_nom->o_val == 1 )
{
fprintf(fortran_out, " subroutine Alloc_agrif_%s(Agrif_Gr)\n", curmodulename);
fprintf(fortran_out, " use Agrif_Util\n");
fprintf(fortran_out, " type(Agrif_grid), pointer :: Agrif_Gr\n");
fprintf(fortran_out, " integer :: i\n");
fprintf(fortran_out, "\n#include \"alloc_agrif_%s.h\"\n", curmodulename);
fprintf(fortran_out, " end subroutine Alloc_agrif_%s\n", curmodulename);
Add_Subroutine_For_Alloc(curmodulename);
}
else
{
parcours_nom = List_Subroutine_For_Alloc;
out = 0;
while ( parcours_nom && out == 0 )
{
if ( !strcasecmp(parcours_nom->o_nom, curmodulename) ) out = 1;
else
{
parcours_nomprec = parcours_nom;
parcours_nom = parcours_nom->suiv;
}
}
if ( out )
{
if ( parcours_nom == List_Subroutine_For_Alloc)
{
List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv;
}
else
{
parcours_nomprec->suiv = parcours_nom->suiv;
parcours_nom = parcours_nomprec->suiv ;
}
}
}
}
}
