Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

SubLoopCreation.c @ 8139

Last change on this file since 8139 was 8139, checked in by timgraham, 7 years ago
Updates to conv library as received from Laurent - required for vertical refinement
Property svn:keywords set to `Id`
File size: 22.8 KB

Line
1	/******************************************************************************/
2	/* */
3	/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */
4	/* */
5	/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */
6	/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */
7	/* This software is governed by the CeCILL-C license under French law and */
8	/* abiding by the rules of distribution of free software. You can use, */
9	/* modify and/ or redistribute the software under the terms of the CeCILL-C */
10	/* license as circulated by CEA, CNRS and INRIA at the following URL */
11	/* "http://www.cecill.info". */
12	/* */
13	/* As a counterpart to the access to the source code and rights to copy, */
14	/* modify and redistribute granted by the license, users are provided only */
15	/* with a limited warranty and the software's author, the holder of the */
16	/* economic rights, and the successive licensors have only limited */
17	/* liability. */
18	/* */
19	/* In this respect, the user's attention is drawn to the risks associated */
20	/* with loading, using, modifying and/or developing or reproducing the */
21	/* software by the user in light of its specific status of free software, */
22	/* that may mean that it is complicated to manipulate, and that also */
23	/* therefore means that it is reserved for developers and experienced */
24	/* professionals having in-depth computer knowledge. Users are therefore */
25	/* encouraged to load and test the software's suitability as regards their */
26	/* requirements in conditions enabling the security of their systems and/or */
27	/* data to be ensured and, more generally, to use and operate it in the */
28	/* same conditions as regards security. */
29	/* */
30	/* The fact that you are presently reading this means that you have had */
31	/* knowledge of the CeCILL-C license and that you accept its terms. */
32	/******************************************************************************/
33	/* version 1.7 */
34	/******************************************************************************/
35	#include <stdio.h>
36	#include <stdlib.h>
37	#include <string.h>
38	#include "decl.h"
39
40
41	/******************************************************************************/
42	/* preparation and write of the argument list of a subroutine */
43	/******************************************************************************/
44
45
46	/******************************************************************************/
47	/* WriteBeginof_SubLoop */
48	/******************************************************************************/
49	/* We should write the head of the subroutine sub_loop_<subroutinename> */
50	/******************************************************************************/
51	/* */
52	/******************************************************************************/
53	void WriteBeginof_SubLoop()
54	{
55	if (todebug == 1) printf("##\n## Enter in HEAD SUBLOOP for \|%s\|\n##\n", subroutinename);
56	if ( IsTabvarsUseInArgument_0() == 1 )
57	{
58	if ( todebug == 1 ) printf("> enter in WriteBeginof_SubLoop : IsTabvarsUseInArgument_0() == 1\n");
59	/* we should add the use agrif_uti l if it is necessary */
60	if (todebug == 1) fprintf(fortran_out,"\n !DEBUG: Avant WriteHeadofSubroutineLoop\n");
61	WriteHeadofSubroutineLoop();
62	if (todebug == 1) fprintf(fortran_out," !DEBUG: Apres WriteHeadofSubroutineLoop\n");
63	fflush(fortran_out);
64	if (todebug == 1) {
65	fprintf(fortran_out," !DEBUG: Avant WriteUsemoduleDeclaration\n");
66	}
67
68	WriteUsemoduleDeclaration(subroutinename);
69	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n");
70	WriteIncludeDeclaration(fortran_out);
71	if (todebug == 1) fprintf(fortran_out," !DEBUG: Avant WriteIncludeDeclaration\n");
72	/* */
73	/* We should write once the declaration of tables (extract */
74	/* from pointer) in the new subroutine */
75	if ( SubInList_ContainsSubroutine() == 0 ) WriteLocalParamDeclaration(fortran_out);
76
77	writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var,fortran_out);
78	writesub_loopdeclaration_tab(List_UsedInSubroutine_Var,fortran_out);
79	WriteArgumentDeclaration_Sort(fortran_out);
80	WriteFunctionDeclaration(fortran_out, 1);
81	}
82	else
83	{
84	if ( todebug == 1 ) printf("> enter in WriteBeginof_SubLoop : IsTabvarsUseInArgument_0() == 0\n");
85	AddUseAgrifUtil_0(fortran_out);
86	WriteUsemoduleDeclaration(subroutinename);
87	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n");
88	WriteIncludeDeclaration(fortran_out);
89	WriteLocalParamDeclaration(fortran_out);
90	WriteArgumentDeclaration_beforecall();
91	if (todebug == 1) fprintf(fortran_out," !DEBUG: Avant WriteFunctionDeclaration\n");
92	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 1);
93	/* writesub_loopdeclaration_scalar(List_SubroutineArgument_Var,fortran_out);
94	writesub_loopdeclaration_tab(List_SubroutineArgument_Var,fortran_out);*/
95	}
96	if ( todebug == 1 ) printf("< out of WriteBeginof_SubLoop\n");
97	if ( todebug == 1 ) printf("## EXIT HEAD SUBLOOP (%s)\n\n", subroutinename);
98	}
99
100	/******************************************************************************/
101	/* WriteVariablelist_subloop */
102	/******************************************************************************/
103	/* This subroutine is used to write the list of the variable which */
104	/* should be called by the sub_loop_<name> subroutine */
105	/* The first part is composed by the list of the local variables */
106	/******************************************************************************/
107	/* */
108	/* List_SubroutineDeclaration_Var a,b,c, & */
109	/* d,e,f, & */
110	/* a,b,c,d,e,f,g,h ========> g,h */
111	/* */
112	/******************************************************************************/
113	void WriteVariablelist_subloop(char *ligne, size_t line_length)
114	{
115	listvar *parcours;
116
117	if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop\n");
118	parcours = List_SubroutineArgument_Var;
119	didvariableadded = 0;
120
121	while ( parcours )
122	{
123	/* if the readed variable is a variable of the subroutine */
124	/* subroutinename we should write the name of this variable */
125	/* in the output file */
126	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
127	{
128	if ( didvariableadded == 1 ) strcat(*ligne,",");
129	if ( (strlen(ligne)+strlen(parcours->var->v_nomvar)+100) > line_length )
130	{
131	*line_length += LONG_M;
132	ligne = realloc( ligne, line_lengthsizeof(char) );
133	}
134	strcat(*ligne,parcours->var->v_nomvar);
135	didvariableadded = 1;
136	}
137	parcours = parcours -> suiv;
138	}
139	parcours = List_FunctionType_Var;
140	while ( parcours )
141	{
142	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
143	{
144	if ( didvariableadded == 1 ) strcat(*ligne,",");
145	if ( (strlen(ligne)+strlen(parcours->var->v_nomvar)+100) > line_length )
146	{
147	*line_length += LONG_M;
148	ligne = realloc( ligne, line_lengthsizeof(char) );
149	}
150	strcat(*ligne,parcours->var->v_nomvar);
151	didvariableadded = 1;
152	}
153	parcours = parcours -> suiv;
154	}
155	if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop\n");
156	}
157
158
159	/******************************************************************************/
160	/* WriteVariablelist_subloop_Call */
161	/******************************************************************************/
162	/* This subroutine is used to write the list of the variable which */
163	/* should be called by the sub_loop_<name> subroutine into the called */
164	/* The second part is composed by the list of the global table */
165	/******************************************************************************/
166	/* */
167	/* List_UsedInSubroutine_Var SubloopScalar = 0 \| SubloopScalar = 1 */
168	/* a,b,c, & \| a,b(1,1),c, & */
169	/* a,b,c,d,e,f,g,h =====> d,e,f, & \| d(1),e(1,1,1),f, & */
170	/* g,h \| g,h(1,1) */
171	/* */
172	/******************************************************************************/
173	void WriteVariablelist_subloop_Call(char *ligne, size_t line_length)
174	{
175	listvar *parcours;
176	char ligne2[LONG_M];
177	int i;
178
179	if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop_Call\n");
180	parcours = List_UsedInSubroutine_Var;
181
182	while ( parcours )
183	{
184	/* if the readed variable is a variable of the subroutine */
185	/* subroutinename we should write the name of this variable */
186	/* in the output file */
187	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
188	(parcours->var->v_pointerdeclare >= 0 \|\| !strcasecmp(parcours->var->v_typevar,"type"))
189	)
190	{
191	if ( didvariableadded == 1 ) strcat(*ligne,",");
192	const char *vres = vargridcurgridtabvars(parcours->var, 0);
193	if ( (strlen(ligne)+strlen(parcours->var->v_nomvar)+100) > line_length )
194	{
195	*line_length += LONG_M;
196	ligne = realloc( ligne, line_lengthsizeof(char) );
197	}
198	strcat(*ligne, vres);
199	/* if it is asked in the call of the conv we should give */
200	/* scalar in argument, so we should put (1,1,1) after the */
201	/* the name of the variable */
202	if ( SubloopScalar != 0 &&
203	(
204	(parcours->var->v_pointerdeclare >= 0 \|\| !strcasecmp(parcours->var->v_typevar,"type"))) &&
205	parcours->var->v_nbdim != 0 )
206	{
207	i = 1;
208	while ( i <= parcours->var->v_nbdim )
209	{
210	if ( i == 1 ) strcat(*ligne,"( ");
211	if ( SubloopScalar == 2 )
212	{
213	strcat(*ligne,":");
214	if ( i != parcours->var->v_nbdim ) strcat(*ligne,",");
215	}
216	else
217	{
218	sprintf(ligne2,"lbound(%s,%d",vargridcurgridtabvars(parcours->var,0),i);
219	strcat(*ligne,ligne2);
220	if ( i != parcours->var->v_nbdim ) strcat(*ligne,"),");
221	}
222	if ( i == parcours->var->v_nbdim ) strcat(*ligne,"))");
223	i++;
224	}
225	}
226	didvariableadded = 1;
227	}
228	parcours = parcours -> suiv;
229	}
230	if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop_Call\n");
231	}
232
233
234	/******************************************************************************/
235	/* WriteVariablelist_subloop_Def */
236	/******************************************************************************/
237	/* This subroutine is used to write the list of the variable which */
238	/* should be called by the sub_loop_<name> subroutine into the def */
239	/* The second part is composed by the list of the global table */
240	/* <name>_tmp */
241	/******************************************************************************/
242	/* */
243	/* List_UsedInSubroutine_Var */
244	/* a-tmp,b-tmp,c_tmp, & */
245	/* a,b,c,d,e,f,g,h =====> d_tmp,e_tmp,f_tmp, & */
246	/* g_tmp,h_tmp */
247	/* */
248	/******************************************************************************/
249	void WriteVariablelist_subloop_Def(char *ligne, size_t line_length)
250	{
251	listvar *parcours;
252
253	if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop_Def\n");
254	parcours = List_UsedInSubroutine_Var;
255
256	while ( parcours )
257	{
258	/* if the readed variable is a variable of the subroutine */
259	/* subrotinename we should write the name of this variable */
260	/* in the output file */
261	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
262	(parcours->var->v_pointerdeclare >= 0 \|\| !strcasecmp(parcours->var->v_typevar,"type")) )
263	{
264	if ( didvariableadded == 1 ) strcat(*ligne,",");
265	if ( (strlen(ligne)+strlen(parcours->var->v_nomvar)+100) > line_length )
266	{
267	*line_length += LONG_M;
268	ligne = realloc( ligne, line_lengthsizeof(char) );
269	}
270	strcat(*ligne,parcours->var->v_nomvar);
271	didvariableadded = 1;
272	}
273	parcours = parcours -> suiv;
274	}
275
276	if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop_Def\n");
277	}
278
279	/******************************************************************************/
280	/* WriteHeadofSubroutineLoop */
281	/******************************************************************************/
282	/* This subroutine is used to write the head of the subroutine */
283	/* Sub_Loop_<name> */
284	/******************************************************************************/
285	/* Sub_loop_subroutine.h */
286	/* */
287	/* subroutine Sub_Loop_subroutine ( & */
288	/* a,b,c, & */
289	/* SubLoopScalar d,e(1,1),f(1,1,1), & */
290	/* g,h & */
291	/* ) */
292	/******************************************************************************/
293	void WriteHeadofSubroutineLoop()
294	{
295	char *ligne;
296	FILE * subloop;
297	size_t line_length;
298
299	ligne = (char*) calloc(LONG_M, sizeof(char));
300	line_length = LONG_M;
301
302	if ( todebug == 1 ) printf("> enter in WriteHeadofSubroutineLoop subroutine %s\n",subroutinename);
303	tofich(fortran_out,"\n",1);
304
305	/* Open this newfile */
306	sprintf(ligne,"Sub_Loop_%s.h",subroutinename);
307	subloop = open_for_write(ligne);
308	/* */
309	if (isrecursive) sprintf(ligne,"recursive subroutine Sub_Loop_%s(",subroutinename);
310	else sprintf(ligne,"subroutine Sub_Loop_%s(",subroutinename);
311
312	/* */
313	if (todebug == 1) fprintf(subloop," !DEBUG: Avant WriteVariablelist_subloop\n");
314	WriteVariablelist_subloop(&ligne,&line_length);
315	WriteVariablelist_subloop_Def(&ligne,&line_length);
316	/* */
317	strcat(ligne,")");
318	tofich(subloop,ligne,1);
319
320	/* if USE agrif_Uti l should be add */
321	if (todebug == 1) fprintf(subloop," !DEBUG: Avant AddUseAgrifUtil_0\n");
322	AddUseAgrifUtil_0(subloop);
323
324	/* */
325	if (todebug == 1) fprintf(subloop," !DEBUG: Apres AddUseAgrifUtil_0\n");
326	oldfortran_out = fortran_out;
327	fortran_out = subloop;
328
329	if ( todebug == 1 ) printf("< out of WriteHeadofSubroutineLoop\n");
330
331	free(ligne);
332	}
333
334	/******************************************************************************/
335	/* closeandcallsubloopandincludeit_0 */
336	/******************************************************************************/
337	/* Firstpass 0 */
338	/* We should close the sub_loop subroutine, call it and close the */
339	/* function (suborfun = 0) */
340	/* subroutine (suborfun = 1) */
341	/* end (suborfun = 2) */
342	/* end program (suborfun = 3) */
343	/* and include the sub_loop subroutine after */
344	/******************************************************************************/
345	/* */
346	/******************************************************************************/
347	void closeandcallsubloopandincludeit_0(int suborfun)
348	{
349	char *ligne;
350	size_t line_length;
351
352	if ( firstpass == 1 ) return;
353	if ( todebug == 1 ) printf("> enter in closeandcallsubloopandincludeit_0\n");
354
355	ligne = (char*) calloc(LONG_M, sizeof(char));
356	line_length = LONG_M;
357
358	if ( IsTabvarsUseInArgument_0() == 1 )
359	{
360	/* We should remove the key word end subroutine */
361	RemoveWordCUR_0(fortran_out,setposcur()-pos_endsubroutine);
362	/* We should close the loop subroutine */
363	tofich(fortran_out,"\n",1);
364	sprintf(ligne,"end subroutine Sub_Loop_%s\n",subroutinename);
365	tofich(fortran_out,ligne,1);
366	fclose(fortran_out);
367	fortran_out = oldfortran_out;
368
369	AddUseAgrifUtilBeforeCall_0(fortran_out);
370
371	WriteArgumentDeclaration_beforecall();
372	if (todebug == 1) fprintf(fortran_out," !DEBUG: Avant WriteFunctionDeclaration\n");
373
374	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0);
375	if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
376	fprintf(fortran_out," call Agrif_Init_Grids()\n");
377	/* Now we add the call af the new subroutine */
378	tofich(fortran_out,"\n",1);
379	sprintf(ligne," call Sub_Loop_%s(",subroutinename);
380	/* Write the list of the local variables used in this new subroutine */
381	WriteVariablelist_subloop(&ligne,&line_length);
382	/* Write the list of the global tables used in this new subroutine */
383	/* in doloop */
384	WriteVariablelist_subloop_Call(&ligne, &line_length);
385	/* Close the parenthesis of the new subroutine called */
386	strcat(ligne,")\n");
387	tofich(fortran_out,ligne,1);
388	/* we should include the above file in the original code */
389
390	/* We should close the original subroutine */
391	if ( suborfun == 3 ) fprintf(fortran_out, " end program %s\n" , subroutinename);
392	if ( suborfun == 2 ) fprintf(fortran_out, " end\n");
393	if ( suborfun == 1 ) fprintf(fortran_out, " end subroutine %s\n", subroutinename);
394	if ( suborfun == 0 ) fprintf(fortran_out, " end function %s\n" , subroutinename);
395
396	fprintf(fortran_out,"\n\n#include \"Sub_Loop_%s.h\"\n",subroutinename);
397	}
398	oldfortran_out = (FILE *)NULL;
399	if ( todebug == 1 ) printf("< out of closeandcallsubloopandincludeit_0\n");
400
401	free(ligne);
402	}
403
404	void closeandcallsubloop_contains_0()
405	{
406	char *ligne;
407	size_t line_length;
408
409	if ( todebug == 1 ) printf("> enter in closeandcallsubloop_contains_0\n");
410	if ( IsTabvarsUseInArgument_0() == 1 )
411	{
412	ligne = (char*) calloc(LONG_M, sizeof(char));
413	line_length = LONG_M;
414	RemoveWordCUR_0(fortran_out,9); // Remove word 'contains'
415	tofich(fortran_out,"\n",1);
416	sprintf(ligne,"end subroutine Sub_Loop_%s\n",subroutinename);
417	tofich(fortran_out,ligne,1);
418	fclose(fortran_out);
419	fortran_out = oldfortran_out;
420
421	AddUseAgrifUtilBeforeCall_0(fortran_out);
422	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n");
423	WriteLocalParamDeclaration(fortran_out);
424	printf("ICI3\n");
425	WriteArgumentDeclaration_beforecall();
426	if (todebug == 1) fprintf(fortran_out," !DEBUG: Avant WriteFunctionDeclaration\n");
427	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0);
428	/* WriteSubroutineDeclaration(0);*/
429	if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
430	fprintf(fortran_out," call Agrif_Init_Grids()\n");
431	/* Now we add the call af the new subroutine */
432	tofich(fortran_out,"\n",1);
433	sprintf(ligne," call Sub_Loop_%s(",subroutinename);
434	/* Write the list of the local variables used in this new subroutine */
435	WriteVariablelist_subloop(&ligne,&line_length);
436	/* Write the list of the global tables used in this new subroutine */
437	/* in doloop */
438	WriteVariablelist_subloop_Call(&ligne, &line_length);
439	/* Close the parenthesis of the new subroutine called */
440	strcat(ligne,")\n");
441	tofich(fortran_out,ligne,1);
442	/* We should close the original subroutine */
443	fprintf(fortran_out, " contains\n");
444	/* we should include the above file in the original code */
445	fprintf(fortran_out,"#include \"Sub_Loop_%s.h\"\n",subroutinename);
446	}
447	oldfortran_out = (FILE *)NULL;
448	if ( todebug == 1 ) printf("< out of closeandcallsubloop_contains_0\n");
449	}

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

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

Context Navigation

source: branches/2017/dev_r8126_UKMO_AGRIF_vert_interp/NEMOGCM/EXTERNAL/AGRIF/LIB/SubLoopCreation.c @ 8139

Download in other formats: