New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

SubLoopCreation.c in branches/2015/dev_r5151_UKMO_ISF/NEMOGCM/EXTERNAL/AGRIF/LIB – NEMO

Context Navigation

source: branches/2015/dev_r5151_UKMO_ISF/NEMOGCM/EXTERNAL/AGRIF/LIB/SubLoopCreation.c @ 5956

Last change on this file since 5956 was 5956, checked in by mathiot, 8 years ago
ISF : merged trunk (5936) into branch
Property svn:keywords set to `Id`
File size: 20.9 KB

Rev	Line
[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	#include "decl.h"
	39
	40
	41	/******************************************************************************/
	42	/* preparation and write of the argument list of a subroutine */
	43	/******************************************************************************/
	44
	45
	46	/******************************************************************************/
[5956]	47	/* WriteBeginof_SubLoop */
[1901]	48	/******************************************************************************/
	49	/* We should write the head of the subroutine sub_loop_<subroutinename> */
	50	/******************************************************************************/
	51	/* */
	52	/******************************************************************************/
[5956]	53	void WriteBeginof_SubLoop()
[1901]	54	{
[5956]	55	if (todebug == 1) printf("##\n## Enter in HEAD SUBLOOP for \|%s\|\n##\n", subroutinename);
	56	if ( IsTabvarsUseInArgument_0() == 1 )
[1901]	57	{
[5956]	58	if ( todebug == 1 ) printf("> enter in WriteBeginof_SubLoop : IsTabvarsUseInArgument_0() == 1\n");
[1901]	59	/* we should add the use agrif_uti l if it is necessary */
	60	WriteHeadofSubroutineLoop();
[2715]	61	WriteUsemoduleDeclaration(subroutinename);
[5956]	62	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n");
	63	WriteIncludeDeclaration(fortran_out);
[1901]	64	/* */
	65	/* We should write once the declaration of tables (extract */
	66	/* from pointer) in the new subroutine */
[5956]	67	if ( SubInList_ContainsSubroutine() == 0 ) WriteLocalParamDeclaration(fortran_out);
[2715]	68
[5956]	69	writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var,fortran_out);
	70	writesub_loopdeclaration_tab(List_UsedInSubroutine_Var,fortran_out);
	71	WriteArgumentDeclaration_Sort(fortran_out);
	72	WriteFunctionDeclaration(fortran_out, 1);
[1901]	73	}
[5956]	74	else
[1901]	75	{
[5956]	76	if ( todebug == 1 ) printf("> enter in WriteBeginof_SubLoop : IsTabvarsUseInArgument_0() == 0\n");
	77	AddUseAgrifUtil_0(fortran_out);
[2715]	78	WriteUsemoduleDeclaration(subroutinename);
[5956]	79	WriteIncludeDeclaration(fortran_out);
	80	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n");
	81	WriteLocalParamDeclaration(fortran_out);
[4147]	82	WriteArgumentDeclaration_beforecall();
[5956]	83	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 1);
	84	/* writesub_loopdeclaration_scalar(List_SubroutineArgument_Var,fortran_out);
	85	writesub_loopdeclaration_tab(List_SubroutineArgument_Var,fortran_out);*/
[1901]	86	}
[5956]	87	if ( todebug == 1 ) printf("< out of WriteBeginof_SubLoop\n");
	88	if ( todebug == 1 ) printf("## EXIT HEAD SUBLOOP (%s)\n\n", subroutinename);
[1901]	89	}
	90
	91	/******************************************************************************/
	92	/* WriteVariablelist_subloop */
	93	/******************************************************************************/
	94	/* This subroutine is used to write the list of the variable which */
	95	/* should be called by the sub_loop_<name> subroutine */
	96	/* The first part is composed by the list of the local variables */
	97	/******************************************************************************/
	98	/* */
	99	/* List_SubroutineDeclaration_Var a,b,c, & */
	100	/* d,e,f, & */
	101	/* a,b,c,d,e,f,g,h ========> g,h */
	102	/* */
	103	/******************************************************************************/
[5956]	104	void WriteVariablelist_subloop(char *ligne)
[1901]	105	{
	106	listvar *parcours;
	107
[5956]	108	if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop\n");
[1901]	109	parcours = List_SubroutineArgument_Var;
	110	didvariableadded = 0;
	111
	112	while ( parcours )
	113	{
	114	/* if the readed variable is a variable of the subroutine */
	115	/* subroutinename we should write the name of this variable */
	116	/* in the output file */
	117	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
	118	{
[5956]	119	if ( didvariableadded == 1 ) strcat(ligne,",");
[1901]	120	strcat(ligne,parcours->var->v_nomvar);
	121	didvariableadded = 1;
[5956]	122	}
[1901]	123	parcours = parcours -> suiv;
	124	}
	125	parcours = List_FunctionType_Var;
	126	while ( parcours )
	127	{
	128	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
	129	{
[5956]	130	if ( didvariableadded == 1 ) strcat(ligne,",");
[1901]	131	strcat(ligne,parcours->var->v_nomvar);
	132	didvariableadded = 1;
[5956]	133	}
[1901]	134	parcours = parcours -> suiv;
	135	}
[5956]	136	if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop\n");
[1901]	137	}
	138
	139
	140	/******************************************************************************/
	141	/* WriteVariablelist_subloop_Call */
	142	/******************************************************************************/
	143	/* This subroutine is used to write the list of the variable which */
	144	/* should be called by the sub_loop_<name> subroutine into the called */
	145	/* The second part is composed by the list of the global table */
	146	/******************************************************************************/
	147	/* */
	148	/* List_UsedInSubroutine_Var SubloopScalar = 0 \| SubloopScalar = 1 */
	149	/* a,b,c, & \| a,b(1,1),c, & */
	150	/* a,b,c,d,e,f,g,h =====> d,e,f, & \| d(1),e(1,1,1),f, & */
	151	/* g,h \| g,h(1,1) */
	152	/* */
	153	/******************************************************************************/
[5956]	154	void WriteVariablelist_subloop_Call(char **ligne, size_t line_length)
[1901]	155	{
	156	listvar *parcours;
[5956]	157	char ligne2[LONG_M];
[1901]	158	int i;
[5956]	159	size_t cur_length;
[1901]	160
[5956]	161	cur_length = line_length;
	162
	163	if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop_Call\n");
[1901]	164	parcours = List_UsedInSubroutine_Var;
[5956]	165
[1901]	166	while ( parcours )
	167	{
	168	/* if the readed variable is a variable of the subroutine */
	169	/* subroutinename we should write the name of this variable */
	170	/* in the output file */
	171	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
[2715]	172	(parcours->var->v_pointerdeclare == 0 \|\| !strcasecmp(parcours->var->v_typevar,"type"))
[1901]	173	)
	174	{
[5956]	175	if ( didvariableadded == 1 ) strcat(*ligne,",");
	176	const char *vres = vargridcurgridtabvars(parcours->var, 0);
	177	if ( (strlen(*ligne)+strlen(vres)+100) > cur_length )
[1901]	178	{
[5956]	179	cur_length += LONG_M;
	180	ligne = realloc( ligne, cur_length*sizeof(char) );
[1901]	181	}
[5956]	182	strcat(*ligne, vres);
[1901]	183	/* if it is asked in the call of the conv we should give */
	184	/* scalar in argument, so we should put (1,1,1) after the */
	185	/* the name of the variable */
	186	if ( SubloopScalar != 0 &&
[2715]	187	(
	188	(parcours->var->v_pointerdeclare == 0 \|\| !strcasecmp(parcours->var->v_typevar,"type"))) &&
[1901]	189	parcours->var->v_nbdim != 0 )
	190	{
	191	i = 1;
	192	while ( i <= parcours->var->v_nbdim )
	193	{
[5956]	194	if ( i == 1 ) strcat(*ligne,"( ");
[1901]	195	if ( SubloopScalar == 2 )
	196	{
[5956]	197	strcat(*ligne,":");
	198	if ( i != parcours->var->v_nbdim ) strcat(*ligne,",");
[1901]	199	}
	200	else
	201	{
[5956]	202	sprintf(ligne2,"lbound(%s,%d",vargridcurgridtabvars(parcours->var,0),i);
	203	strcat(*ligne,ligne2);
	204	if ( i != parcours->var->v_nbdim ) strcat(*ligne,"),");
[1901]	205	}
[5956]	206	if ( i == parcours->var->v_nbdim ) strcat(*ligne,"))");
[1901]	207	i++;
	208	}
	209	}
	210	didvariableadded = 1;
	211	}
	212	parcours = parcours -> suiv;
	213	}
[5956]	214	if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop_Call\n");
[1901]	215	}
	216
	217
	218	/******************************************************************************/
	219	/* WriteVariablelist_subloop_Def */
	220	/******************************************************************************/
	221	/* This subroutine is used to write the list of the variable which */
	222	/* should be called by the sub_loop_<name> subroutine into the def */
	223	/* The second part is composed by the list of the global table */
	224	/* <name>_tmp */
	225	/******************************************************************************/
	226	/* */
	227	/* List_UsedInSubroutine_Var */
	228	/* a-tmp,b-tmp,c_tmp, & */
	229	/* a,b,c,d,e,f,g,h =====> d_tmp,e_tmp,f_tmp, & */
	230	/* g_tmp,h_tmp */
	231	/* */
	232	/******************************************************************************/
[5956]	233	void WriteVariablelist_subloop_Def(char *ligne)
[1901]	234	{
	235	listvar *parcours;
	236
[5956]	237	if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop_Def\n");
[1901]	238	parcours = List_UsedInSubroutine_Var;
[5956]	239
[1901]	240	while ( parcours )
	241	{
	242	/* if the readed variable is a variable of the subroutine */
	243	/* subrotinename we should write the name of this variable */
	244	/* in the output file */
	245	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
[5956]	246	(parcours->var->v_pointerdeclare == 0 \|\| !strcasecmp(parcours->var->v_typevar,"type")) )
[1901]	247	{
[5956]	248	if ( didvariableadded == 1 ) strcat(ligne,",");
[1901]	249	strcat(ligne,parcours->var->v_nomvar);
	250	didvariableadded = 1;
[5956]	251	}
[1901]	252	parcours = parcours -> suiv;
	253	}
	254	Save_Length(ligne,41);
[5956]	255	if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop_Def\n");
[1901]	256	}
	257
	258	/******************************************************************************/
	259	/* WriteHeadofSubroutineLoop */
	260	/******************************************************************************/
	261	/* This subroutine is used to write the head of the subroutine */
	262	/* Sub_Loop_<name> */
	263	/******************************************************************************/
	264	/* Sub_loop_subroutine.h */
	265	/* */
	266	/* subroutine Sub_Loop_subroutine ( & */
	267	/* a,b,c, & */
	268	/* SubLoopScalar d,e(1,1),f(1,1,1), & */
	269	/* g,h & */
	270	/* ) */
	271	/******************************************************************************/
	272	void WriteHeadofSubroutineLoop()
	273	{
[5956]	274	char ligne[LONG_M];
[1901]	275	FILE * subloop;
	276
[5956]	277	if ( todebug == 1 ) printf("> enter in WriteHeadofSubroutineLoop\n");
	278	tofich(fortran_out,"\n",1);
[1901]	279	/* Open this newfile */
	280	sprintf(ligne,"Sub_Loop_%s.h",subroutinename);
[5956]	281	subloop = open_for_write(ligne);
[1901]	282	/* */
[5956]	283	if (isrecursive) sprintf(ligne,"recursive subroutine Sub_Loop_%s(",subroutinename);
	284	else sprintf(ligne,"subroutine Sub_Loop_%s(",subroutinename);
[1901]	285	/* */
[5956]	286	WriteVariablelist_subloop(ligne);
	287	WriteVariablelist_subloop_Def(ligne);
[1901]	288	/* */
[5956]	289	strcat(ligne,")");
[2715]	290	tofich(subloop,ligne,1);
[1901]	291	/* if USE agrif_Uti l should be add */
	292	AddUseAgrifUtil_0(subloop);
	293	/* */
[5956]	294	oldfortran_out = fortran_out;
	295	fortran_out = subloop;
	296	if ( todebug == 1 ) printf("< out of WriteHeadofSubroutineLoop\n");
[1901]	297	}
	298
	299	/******************************************************************************/
	300	/* closeandcallsubloopandincludeit_0 */
	301	/******************************************************************************/
	302	/* Firstpass 0 */
	303	/* We should close the sub_loop subroutine, call it and close the */
	304	/* function (suborfun = 0) */
	305	/* subroutine (suborfun = 1) */
	306	/* end (suborfun = 2) */
	307	/* end program (suborfun = 3) */
	308	/* and include the sub_loop subroutine after */
	309	/******************************************************************************/
	310	/* */
	311	/******************************************************************************/
	312	void closeandcallsubloopandincludeit_0(int suborfun)
	313	{
[5956]	314	char *ligne;
[1901]	315
[5956]	316	if ( firstpass == 1 ) return;
	317	if ( todebug == 1 ) printf("> enter in closeandcallsubloopandincludeit_0\n");
[2715]	318
[5956]	319	ligne = (char*) calloc(LONG_M, sizeof(char));
	320
[1901]	321	if ( IsTabvarsUseInArgument_0() == 1 )
	322	{
	323	/* We should remove the key word end subroutine */
[5956]	324	RemoveWordCUR_0(fortran_out,setposcur()-pos_endsubroutine);
[1901]	325	/* We should close the loop subroutine */
[5956]	326	tofich(fortran_out,"\n",1);
	327	sprintf(ligne,"end subroutine Sub_Loop_%s\n",subroutinename);
	328	tofich(fortran_out,ligne,1);
	329	fclose(fortran_out);
	330	fortran_out = oldfortran_out;
[1901]	331
[5956]	332	AddUseAgrifUtilBeforeCall_0(fortran_out);
[4147]	333	WriteArgumentDeclaration_beforecall();
[5956]	334	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0);
[1901]	335	if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
[5956]	336	fprintf(fortran_out," call Agrif_Init_Grids()\n");
[1901]	337	/* Now we add the call af the new subroutine */
[5956]	338	tofich(fortran_out,"\n",1);
	339	sprintf(ligne," call Sub_Loop_%s(",subroutinename);
[1901]	340	/* Write the list of the local variables used in this new subroutine */
[5956]	341	WriteVariablelist_subloop(ligne);
[1901]	342	/* Write the list of the global tables used in this new subroutine */
	343	/* in doloop */
[5956]	344	WriteVariablelist_subloop_Call(&ligne, LONG_M);
[1901]	345	/* Close the parenthesis of the new subroutine called */
[5956]	346	strcat(ligne,")\n");
	347	tofich(fortran_out,ligne,1);
	348	/* we should include the above file in the original code */
[2715]	349
[1901]	350	/* We should close the original subroutine */
[5956]	351	if ( suborfun == 3 ) fprintf(fortran_out, " end program %s\n" , subroutinename);
	352	if ( suborfun == 2 ) fprintf(fortran_out, " end\n");
	353	if ( suborfun == 1 ) fprintf(fortran_out, " end subroutine %s\n", subroutinename);
	354	if ( suborfun == 0 ) fprintf(fortran_out, " end function %s\n" , subroutinename);
	355
	356	fprintf(fortran_out,"\n\n#include \"Sub_Loop_%s.h\"\n",subroutinename);
	357	}
	358	oldfortran_out = (FILE *)NULL;
	359	if ( todebug == 1 ) printf("< out of closeandcallsubloopandincludeit_0\n");
[1901]	360	}
	361
	362	void closeandcallsubloop_contains_0()
	363	{
[5956]	364	char *ligne;
[1901]	365
[5956]	366	if ( todebug == 1 ) printf("> enter in closeandcallsubloop_contains_0\n");
[1901]	367	if ( IsTabvarsUseInArgument_0() == 1 )
	368	{
[5956]	369	ligne = (char*) calloc(LONG_M, sizeof(char));
	370	RemoveWordCUR_0(fortran_out,9); // Remove word 'contains'
	371	tofich(fortran_out,"\n",1);
	372	sprintf(ligne,"end subroutine Sub_Loop_%s\n",subroutinename);
	373	tofich(fortran_out,ligne,1);
	374	fclose(fortran_out);
	375	fortran_out = oldfortran_out;
[1901]	376
[5956]	377	AddUseAgrifUtilBeforeCall_0(fortran_out);
	378
	379	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n");
	380	WriteLocalParamDeclaration(fortran_out);
[4147]	381	WriteArgumentDeclaration_beforecall();
[5956]	382	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0);
	383	/* WriteSubroutineDeclaration(0);*/
[1901]	384	if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
[5956]	385	fprintf(fortran_out," call Agrif_Init_Grids()\n");
[1901]	386	/* Now we add the call af the new subroutine */
[5956]	387	tofich(fortran_out,"\n",1);
	388	sprintf(ligne," call Sub_Loop_%s(",subroutinename);
[1901]	389	/* Write the list of the local variables used in this new subroutine */
[5956]	390	WriteVariablelist_subloop(ligne);
[1901]	391	/* Write the list of the global tables used in this new subroutine */
	392	/* in doloop */
[5956]	393	WriteVariablelist_subloop_Call(&ligne, LONG_M);
[1901]	394	/* Close the parenthesis of the new subroutine called */
[5956]	395	strcat(ligne,")\n");
	396	tofich(fortran_out,ligne,1);
[1901]	397	/* We should close the original subroutine */
[5956]	398	fprintf(fortran_out, " contains\n");
[1901]	399	/* we should include the above file in the original code */
[5956]	400	fprintf(fortran_out,"#include \"Sub_Loop_%s.h\"\n",subroutinename);
[1901]	401	}
[5956]	402	oldfortran_out = (FILE *)NULL;
	403	if ( todebug == 1 ) printf("< out of closeandcallsubloop_contains_0\n");
[1901]	404	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: