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

Context Navigation

source: NEMO/releases/CMIP5_IPSL/AGRIF/LIB/SubLoopCreation.c @ 11998

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

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

Download in other formats: