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 trunk/AGRIF/LIB – NEMO

Context Navigation

source: trunk/AGRIF/LIB/SubLoopCreation.c @ 663

Last change on this file since 663 was 663, checked in by opalod, 17 years ago
RB: update CONV
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 25.4 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.6 */
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	/* writeheadnewsub_0 */
48	/******************************************************************************/
49	/* Firstpass 0 */
50	/* We should write the head of the subroutine sub_loop_<subroutinename> */
51	/* suborfunc = 1 from subroutine */
52	/* suborfunc = 2 from function */
53	/******************************************************************************/
54	/* */
55	/******************************************************************************/
56	void writeheadnewsub_0(int suborfunc)
57	{
58	int out;
59	char ligne[LONGNOM];
60	listusemodule *newmodule;
61
62	if ( firstpass == 0 && IsTabvarsUseInArgument_0() == 1 )
63	{
64	if ( todebug == 1 ) printf("Enter in writeheadnewsub_0\n");
65	/* we should add the use agrif_uti l if it is necessary */
66	WriteHeadofSubroutineLoop();
67	WriteUsemoduleDeclaration();
68	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
69	" IMPLICIT NONE\n");
70	WriteIncludeDeclaration();
71	/* */
72	/* We should write once the declaration of tables (extract */
73	/* from pointer) in the new subroutine */
74	if ( mark == 1 ) fprintf(fortranout,"!!! 000000000000000 \n");
75	if ( SubInList_ContainsSubroutine() == 0 ) WriteLocalParamDeclaration();
76	if ( mark == 1 ) fprintf(fortranout,"!!! 111111111111111 \n");
77
78	sprintf(ligne,"\n#include \"ParamFile%s.h\" \n",subroutinename);
79	tofich(fortranout,ligne,1);
80
81	/* writesub_loopdeclaration_scalar(List_SubroutineArgument_Var,paramout);*/
82	WriteArgumentDeclaration_Sort();
83	/* writesub_loopdeclaration_tab(List_SubroutineArgument_Var,fortranout);*/
84
85	if ( mark == 1 ) fprintf(fortranout,"!!! 222222222222222 \n");
86	writesub_loopdeclaration_tab(List_UsedInSubroutine_Var,fortranout);
87	if ( mark == 1 ) fprintf(fortranout,"!!! 333333333333333 \n");
88	writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var,paramout);
89	if ( mark == 1 ) fprintf(fortranout,"!!! 444444444444444 \n");
90	/* now we should write the function declaration */
91	/* case if it is the */
92	WriteFunctionDeclaration();
93	if ( mark == 1 ) fprintf(fortranout,"!!! 555555555555555 \n");
94	if ( SubInList_ContainsSubroutine() == 0 ) WriteSubroutineDeclaration(1);
95	if ( mark == 1 ) fprintf(fortranout,"!!! 666666666666666 \n");
96	if ( todebug == 1 ) printf("Out of writeheadnewsub_0\n");
97	}
98	else if ( firstpass == 0 )
99	{
100	AddUseAgrifUtil_0(fortranout);
101	WriteUsemoduleDeclaration();
102	WriteIncludeDeclaration();
103	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
104	" IMPLICIT NONE\n");
105	if ( mark == 1 ) fprintf(fortranout,"!!! aaaaaaaaaaaaaaa \n");
106	WriteLocalParamDeclaration();
107	if ( mark == 1 ) fprintf(fortranout,"!!! bbbbbbbbbbbbbbb \n");
108	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration();
109	WriteArgumentDeclaration_beforecall();
110	/* writesub_loopdeclaration_scalar(List_SubroutineArgument_Var,fortranout);
111	writesub_loopdeclaration_tab(List_SubroutineArgument_Var,fortranout);*/
112	if ( mark == 1 ) fprintf(fortranout,"!!! ccccccccccccccc \n");
113	if ( mark == 1 ) fprintf(fortranout,"!!! ddddddddddddddd \n");
114	WriteSubroutineDeclaration(1);
115	if ( mark == 1 ) fprintf(fortranout,"!!! eeeeeeeeeeeeeee \n");
116	}
117	}
118
119
120	/******************************************************************************/
121	/* WriteVariablelist_subloop */
122	/******************************************************************************/
123	/* This subroutine is used to write the list of the variable which */
124	/* should be called by the sub_loop_<name> subroutine */
125	/* The first part is composed by the list of the local variables */
126	/******************************************************************************/
127	/* */
128	/* List_SubroutineDeclaration_Var a,b,c, & */
129	/* d,e,f, & */
130	/* a,b,c,d,e,f,g,h ========> g,h */
131	/* */
132	/******************************************************************************/
133	void WriteVariablelist_subloop(FILE *outputfile)
134	{
135	listvar *parcours;
136	char ligne[LONGNOM];
137	int compteur;
138
139	if ( todebug == 1 ) printf("Enter in WriteVariablelist_subloop\n");
140	parcours = List_SubroutineArgument_Var;
141	didvariableadded = 0;
142	compteur = 0 ;
143
144	while ( parcours )
145	{
146	/* if the readed variable is a variable of the subroutine */
147	/* subroutinename we should write the name of this variable */
148	/* in the output file */
149	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
150	{
151	if ( didvariableadded == 0 )
152	{
153	strcpy(ligne,"");
154	}
155	else
156	{
157	if ( compteur == 0 ) strcpy(ligne,"");
158	strcat(ligne,",");
159	}
160	strcat(ligne,parcours->var->v_nomvar);
161	didvariableadded = 1;
162	compteur = compteur + 1;
163	if ( compteur == 3 )
164	{
165	if ( retour77 == 0 )
166	{
167	strcat(ligne," &");
168	fprintf(outputfile,"\n %s",ligne);
169	}
170	else fprintf(outputfile,"\n & %s",ligne);
171	compteur = 0;
172	}
173	}
174	parcours = parcours -> suiv;
175	}
176	parcours = List_FunctionType_Var;
177	while ( parcours )
178	{
179	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
180	{
181	if ( didvariableadded == 0 )
182	{
183	strcpy(ligne,"");
184	}
185	else
186	{
187	if ( compteur == 0 ) strcpy(ligne,"");
188	strcat(ligne,",");
189	}
190	strcat(ligne,parcours->var->v_nomvar);
191	didvariableadded = 1;
192	compteur = compteur + 1;
193	if ( compteur == 3 )
194	{
195	if ( retour77 == 0 )
196	{
197	strcat(ligne," &");
198	fprintf(outputfile,"\n %s",ligne);
199	}
200	else fprintf(outputfile,"\n & %s",ligne);
201	compteur = 0;
202	}
203	}
204	parcours = parcours -> suiv;
205	}
206	if ( compteur != 3 && compteur != 0 )
207	{
208	if ( retour77 == 0 ) fprintf(outputfile,"\n %s &",ligne);
209	else fprintf(outputfile,"\n & %s ",ligne);
210	}
211	if ( todebug == 1 ) printf("Out of WriteVariablelist_subloop\n");
212	}
213
214
215	/******************************************************************************/
216	/* WriteVariablelist_subloop_Call */
217	/******************************************************************************/
218	/* This subroutine is used to write the list of the variable which */
219	/* should be called by the sub_loop_<name> subroutine into the called */
220	/* The second part is composed by the list of the global table */
221	/******************************************************************************/
222	/* */
223	/* List_UsedInSubroutine_Var SubloopScalar = 0 \| SubloopScalar = 1 */
224	/* a,b,c, & \| a,b(1,1),c, & */
225	/* a,b,c,d,e,f,g,h =====> d,e,f, & \| d(1),e(1,1,1),f, & */
226	/* g,h \| g,h(1,1) */
227	/* */
228	/******************************************************************************/
229	void WriteVariablelist_subloop_Call(FILE *outputfile)
230	{
231	listvar *parcours;
232	char ligne[LONGNOM*100];
233	char ligne2[10];
234	int i;
235
236	if ( todebug == 1 ) printf("Enter in WriteVariablelist_subloop_Call\n");
237	parcours = List_UsedInSubroutine_Var;
238	while ( parcours )
239	{
240	/* if the readed variable is a variable of the subroutine */
241	/* subroutinename we should write the name of this variable */
242	/* in the output file */
243	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
244	parcours->var->v_allocatable == 0 &&
245	parcours->var->v_pointerdeclare == 0
246	)
247	{
248	if ( didvariableadded == 0 )
249	{
250	strcpy(ligne,"");
251	}
252	else
253	{
254	strcpy(ligne,"");
255	strcat(ligne,",");
256	}
257	strcat(ligne,vargridcurgridtabvars(parcours->var,0));
258	/* if it is asked in the call of the conv we should give */
259	/* scalar in argument, so we should put (1,1,1) after the */
260	/* the name of the variable */
261	if ( SubloopScalar != 0 &&
262	(IsVarAllocatable_0(parcours->var->v_nomvar) == 0 &&
263	parcours->var->v_pointerdeclare == 0 ) &&
264	parcours->var->v_nbdim != 0 )
265	{
266	i = 1;
267	while ( i <= parcours->var->v_nbdim )
268	{
269	if ( i == 1 ) strcat(ligne,"( ");
270	if ( SubloopScalar == 2 )
271	{
272	strcat(ligne,":");
273	if ( i != parcours->var->v_nbdim ) strcat(ligne,",");
274	}
275	else
276	{
277	strcat(ligne," lbound( ");
278	strcat(ligne,vargridcurgridtabvars(parcours->var,0));
279	strcat(ligne,",");
280	strcpy(ligne2,"");
281	sprintf(ligne2,"%d",i);
282	strcat(ligne,ligne2);
283	if ( i != parcours->var->v_nbdim ) strcat(ligne,"),");
284	}
285	if ( i == parcours->var->v_nbdim ) strcat(ligne,"))");
286	i++;
287	}
288	}
289	didvariableadded = 1;
290	if ( retour77 == 0 )
291	{
292	strcat(ligne," &");
293	fprintf(outputfile,"\n");
294	}
295	else fprintf(outputfile,"\n & ");
296	tofich(outputfile,ligne,0);
297	}
298	parcours = parcours -> suiv;
299	}
300	/* Now we should replace the last ", &" by " &" */
301	if ( didvariableadded != 0 && retour77 == 0 ) fseek(outputfile,-1,SEEK_CUR);
302	if ( didvariableadded == 0 ) fseek(outputfile,-2,SEEK_CUR);
303	if ( todebug == 1 ) printf("Out of WriteVariablelist_subloop_Call\n");
304	}
305
306
307	/******************************************************************************/
308	/* WriteVariablelist_subloop_Def */
309	/******************************************************************************/
310	/* This subroutine is used to write the list of the variable which */
311	/* should be called by the sub_loop_<name> subroutine into the def */
312	/* The second part is composed by the list of the global table */
313	/* <name>_tmp */
314	/******************************************************************************/
315	/* */
316	/* List_UsedInSubroutine_Var */
317	/* a-tmp,b-tmp,c_tmp, & */
318	/* a,b,c,d,e,f,g,h =====> d_tmp,e_tmp,f_tmp, & */
319	/* g_tmp,h_tmp */
320	/* */
321	/******************************************************************************/
322	void WriteVariablelist_subloop_Def(FILE *outputfile)
323	{
324	listvar *parcours;
325	char ligne[LONGNOM];
326	int compteur;
327
328	if ( todebug == 1 ) printf("Enter in WriteVariablelist_subloop_Def\n");
329	parcours = List_UsedInSubroutine_Var;
330	compteur = 0 ;
331	while ( parcours )
332	{
333	/* if the readed variable is a variable of the subroutine */
334	/* subrotinename we should write the name of this variable */
335	/* in the output file */
336	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) &&
337	parcours->var->v_allocatable == 0 &&
338	parcours->var->v_pointerdeclare == 0
339	)
340	{
341	if ( didvariableadded == 0 )
342	{
343	strcpy(ligne,"");
344	}
345	else
346	{
347	if ( compteur == 0 ) strcpy(ligne,"");
348	strcat(ligne,",");
349	}
350	strcat(ligne,parcours->var->v_nomvar);
351	compteur = compteur + 1;
352	didvariableadded = 1;
353	if ( compteur == 3 )
354	{
355	if ( retour77 == 0 )
356	{
357	strcat(ligne," &");
358	fprintf(outputfile,"\n %s",ligne);
359	}
360	else fprintf(outputfile,"\n & %s",ligne);
361	compteur = 0;
362	}
363	}
364	parcours = parcours -> suiv;
365	}
366	if ( compteur != 3 && compteur != 0 )
367	{
368	if ( retour77 == 0 ) fprintf(outputfile,"\n %s &",ligne);
369	else fprintf(outputfile,"\n & %s",ligne);
370	}
371
372	/* Now we should replace the last ", &" by " &" */
373	if ( didvariableadded != 0 && retour77 == 0 ) fseek(outputfile,-1,SEEK_CUR);
374	if ( didvariableadded == 0 ) fseek(outputfile,-1,SEEK_CUR);
375	if ( todebug == 1 ) printf("Out of WriteVariablelist_subloop_Def\n");
376	}
377
378
379
380	/******************************************************************************/
381	/* WriteHeadofSubroutineLoop */
382	/******************************************************************************/
383	/* This subroutine is used to write the head of the subroutine */
384	/* Sub_Loop_<name> */
385	/******************************************************************************/
386	/* Sub_loop_subroutine.h */
387	/* */
388	/* subroutine Sub_Loop_subroutine ( & */
389	/* a,b,c, & */
390	/* SubLoopScalar d,e(1,1),f(1,1,1), & */
391	/* g,h & */
392	/* ) */
393	/******************************************************************************/
394	void WriteHeadofSubroutineLoop()
395	{
396	char ligne[LONGNOM];
397	FILE * subloop;
398
399	if ( todebug == 1 ) printf("Enter in WriteHeadofSubroutineLoop\n");
400	tofich(fortranout,"\n",1);
401	/* Open this newfile */
402	sprintf(ligne,"Sub_Loop_%s.h",subroutinename);
403	subloop = associate(ligne);
404	/* */
405	if ( retour77 == 0 ) sprintf(ligne," subroutine Sub_Loop_%s( &"
406	,subroutinename);
407	else sprintf(ligne," subroutine Sub_Loop_%s( ",subroutinename);
408	fprintf(subloop,ligne);
409	/* */
410	WriteVariablelist_subloop(subloop);
411	WriteVariablelist_subloop_Def(subloop);
412	/* */
413	sprintf(ligne,")");
414	tofich(subloop,ligne,1);
415	/* if USE agrif_Uti l should be add */
416	AddUseAgrifUtil_0(subloop);
417	/* */
418	oldfortranout = fortranout;
419	fortranout = subloop;
420	if ( todebug == 1 ) printf("Out of WriteHeadofSubroutineLoop\n");
421	}
422
423	/******************************************************************************/
424	/* closeandcallsubloopandincludeit_0 */
425	/******************************************************************************/
426	/* Firstpass 0 */
427	/* We should close the sub_loop subroutine, call it and close the */
428	/* function (suborfun = 0) */
429	/* subroutine (suborfun = 1) */
430	/* end (suborfun = 2) */
431	/* end program (suborfun = 3) */
432	/* and include the sub_loop subroutine after */
433	/******************************************************************************/
434	/* */
435	/******************************************************************************/
436	void closeandcallsubloopandincludeit_0(int suborfun, char endsub[LONGNOM])
437	{
438	char ligne[LONGNOM];
439
440	if ( firstpass == 0 )
441	{
442	if ( todebug == 1 ) printf("Enter in closeandcallsubloopandincludeit_0\n");
443	if ( IsTabvarsUseInArgument_0() == 1 )
444	{
445	/* We should remove the key word end subroutine */
446	RemoveWordCUR_0(fortranout,(long)(-(pos_cur-pos_endsubroutine)),
447	pos_cur-pos_endsubroutine);
448	/* We should close the loop subroutine */
449	sprintf(ligne,"\n end subroutine Sub_Loop_%s",subroutinename);
450	tofich(fortranout,ligne,1);
451	fclose(fortranout);
452	fortranout = oldfortranout;
453	AddUseAgrifUtilBeforeCall_0(fortranout);
454	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration();
455	WriteArgumentDeclaration_beforecall();
456	if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
457	fprintf(oldfortranout," Call Agrif_Init_Grids () \n");
458	/* Now we add the call af the new subroutine */
459	if ( retour77 == 0 ) sprintf(ligne,"\n Call Sub_Loop_%s( &"
460	,subroutinename);
461	else sprintf(ligne,"\n Call Sub_Loop_%s( ",subroutinename);
462	fprintf(fortranout,ligne);
463	/* Write the list of the local variables used in this new subroutine */
464	WriteVariablelist_subloop(fortranout);
465	/* Write the list of the global tables used in this new subroutine */
466	/* in doloop */
467	WriteVariablelist_subloop_Call(fortranout);
468	/* Close the parenthesis of the new subroutine called */
469	sprintf(ligne,")");
470	tofich(fortranout,ligne,1);
471	/* We should close the original subroutine */
472	if ( suborfun == 3 ) sprintf(ligne,"\n end program %s"
473	,subroutinename);
474	if ( suborfun == 2 ) sprintf(ligne,"\n end");
475	if ( suborfun == 1 ) sprintf(ligne,"\n end subroutine %s"
476	,subroutinename);
477	if ( suborfun == 0 ) sprintf(ligne,"\n end function %s"
478	,subroutinename);
479	tofich(fortranout,ligne,1);
480	/* we should include the above file in the original code */
481	sprintf(ligne,"\n#include \"Sub_Loop_%s.h\" \n",subroutinename);
482	tofich(fortranout,ligne,1);
483	}
484	if ( todebug == 1 ) printf("Out of closeandcallsubloopandincludeit_0\n");
485	}
486	}
487
488
489
490
491	void closeandcallsubloop_contains_0(int suborfun, char endsub[LONGNOM])
492	{
493	char ligne[LONGNOM];
494
495	if ( firstpass == 0 )
496	{
497	if ( todebug == 1 ) printf("Enter in closeandcallsubloopandincludeit_0\n");
498	if ( IsTabvarsUseInArgument_0() == 1 )
499	{
500	Remove_Word_Contains_0();
501	sprintf(ligne,"\n end subroutine Sub_Loop_%s",subroutinename);
502	tofich(fortranout,ligne,1);
503	fclose(fortranout);
504	fortranout = oldfortranout;
505	AddUseAgrifUtilBeforeCall_0(fortranout);
506	if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortranout,
507	" IMPLICIT NONE\n");
508	WriteLocalParamDeclaration();
509	if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration();
510	WriteArgumentDeclaration_beforecall();
511	WriteSubroutineDeclaration(0);
512	if ( !strcasecmp(subofagrifinitgrids,subroutinename) )
513	fprintf(oldfortranout," Call Agrif_Init_Grids () \n");
514	/* Now we add the call af the new subroutine */
515	if ( retour77 == 0 ) sprintf(ligne,"\n Call Sub_Loop_%s( &"
516	,subroutinename);
517	else sprintf(ligne,"\n Call Sub_Loop_%s( ",subroutinename);
518	fprintf(fortranout,ligne);
519	/* Write the list of the local variables used in this new subroutine */
520	WriteVariablelist_subloop(fortranout);
521	/* Write the list of the global tables used in this new subroutine */
522	/* in doloop */
523	WriteVariablelist_subloop_Call(fortranout);
524	/* Close the parenthesis of the new subroutine called */
525	sprintf(ligne,")");
526	tofich(fortranout,ligne,1);
527	/* We should close the original subroutine */
528	sprintf(ligne,"\n contains");
529	tofich(fortranout,ligne,1);
530	/* we should include the above file in the original code */
531	sprintf(ligne,"\n#include \"Sub_Loop_%s.h\" \n",subroutinename);
532	tofich(fortranout,ligne,1);
533	}
534	if ( todebug == 1 ) printf("Out of closeandcallsubloopandincludeit_0\n");
535	}
536	}

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

Download in other formats: