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.

UtilFortran.c in trunk/NEMOGCM/EXTERNAL/AGRIF/LIB – NEMO

Context Navigation

source: trunk/NEMOGCM/EXTERNAL/AGRIF/LIB/UtilFortran.c @ 2528

Last change on this file since 2528 was 2528, checked in by rblod, 13 years ago
Update NEMOGCM from branch nemo_v3_3_beta
Property svn:keywords set to `Id`
File size: 25.6 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	/* initdimprob */
42	/******************************************************************************/
43	/* This subroutine is used to initialized grid dimension variable */
44	/******************************************************************************/
45	/* */
46	/* */
47	/* */
48	/******************************************************************************/
49	void initdimprob(int dimprobmod, char * nx, char * ny,char* nz)
50	{
51	dimprob = dimprobmod;
52
53	strcpy(nbmaillesX,nx);
54	strcpy(nbmaillesY,ny);
55	strcpy(nbmaillesZ,nz);
56	}
57
58	/******************************************************************************/
59	/* Variableshouldberemove */
60	/******************************************************************************/
61	/* Firstpass 0 */
62	/******************************************************************************/
63	/* */
64	/* Agrif_<toto>(variable) ====> Agrif_<toto>(variable) */
65	/* */
66	/******************************************************************************/
67	int Variableshouldberemove(char *nom)
68	{
69
70	int remove;
71
72	remove = 0 ;
73
74	if ( remove == 0 && Agrif_in_Tok_NAME(nom) == 1 ) remove = 1 ;
75
76	return remove;
77	}
78
79	/******************************************************************************/
80	/* variableisglobal */
81	/******************************************************************************/
82	/* This subroutine is to know if a variable is global */
83	/******************************************************************************/
84	int variableisglobal(listvar curvar, listvar listin)
85	{
86	int Globalite;
87	listvar *newvar;
88
89
90	Globalite = 0;
91	newvar = listin;
92	while ( newvar && Globalite == 0 )
93	{
94	if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) )
95	{
96	Globalite = 1;
97	/* Now we should give the definition of the variable in the */
98	/* table List_UsedInSubroutine_Var */
99	strcpy(curvar->var->v_typevar,newvar->var->v_typevar);
100	strcpy(curvar->var->v_dimchar,newvar->var->v_dimchar);
101	curvar->var->v_nbdim = newvar->var->v_nbdim;
102	curvar->var->v_dimensiongiven = newvar->var->v_dimensiongiven;
103	curvar->var->v_allocatable = newvar->var->v_allocatable;
104	curvar->var->v_pointerdeclare = newvar->var->v_pointerdeclare;
105	curvar->var->v_indicetabvars = newvar->var->v_indicetabvars;
106	strcpy(curvar->var->v_nameinttypename,newvar->var->v_nameinttypename);
107	strcpy(curvar->var->v_precision,newvar->var->v_precision);
108	strcpy(curvar->var->v_readedlistdimension,
109	newvar->var->v_readedlistdimension);
110	strcpy(curvar->var->v_commoninfile,newvar->var->v_commoninfile);
111	}
112	else
113	{
114	newvar = newvar->suiv;
115	}
116	}
117
118	return Globalite ;
119	}
120
121	int VariableIsInListCommon(listvar curvar,listvar listin)
122	{
123	int present;
124	listvar *newvar;
125
126	present = 0;
127	newvar = listin;
128	while ( newvar && present == 0 )
129	{
130	if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) &&
131	!strcasecmp(newvar->var->v_subroutinename,
132	curvar->var->v_subroutinename)
133	)
134	{
135	CopyRecord(curvar->var,newvar->var);
136	present = 1;
137	}
138	else newvar = newvar->suiv;
139	}
140
141	return present;
142	}
143
144	int VariableIsInList(listvar curvar,listvar listin)
145	{
146	int present;
147	listvar *newvar;
148
149	present = 0;
150	newvar = listin;
151	while ( newvar && present == 0 )
152	{
153	if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) )
154	{
155	CopyRecord(curvar->var,newvar->var);
156	present = 1;
157	}
158	else newvar = newvar->suiv;
159	}
160
161	return present;
162	}
163
164	/******************************************************************************/
165	/* variableisglobalinmodule */
166	/******************************************************************************/
167	/* This subroutine is to know if a variable is global */
168	/******************************************************************************/
169	void variableisglobalinmodule(listcouple listin, char module, FILE *fileout, long int oldposcuruse)
170	{
171	int Globalite;
172	listcouple *newvar;
173	listcouple *newvarprec;
174	listvar *tempo;
175	listvar *newvar2;
176	int out;
177	char truename[LONG_C];
178
179	Globalite = 1;
180	newvarprec = (listcouple *)NULL;
181	tempo = (listvar *)NULL;
182	tempo = Readthedependfile(module,tempo);
183	newvar = listin;
184
185	while ( newvar )
186	{
187	if (!strcmp(newvar->c_namepointedvar,"")) {
188	strcpy(truename,newvar->c_namevar);
189	}
190	else
191	{
192	strcpy(truename,newvar->c_namepointedvar);
193	}
194
195	out = 0;
196	newvar2 = tempo;
197	while ( newvar2 && out == 0 )
198	{
199	if ( !strcasecmp(newvar2->var->v_nomvar,truename) ) out = 1;
200	else newvar2 = newvar2 ->suiv;
201	}
202	if ( out == 1 )
203	{
204	/* remove from the listin */
205	if ( newvar == listin )
206	{
207	listin = listin->suiv;
208	newvar = listin;
209	}
210	else
211	{
212	newvarprec->suiv = newvar->suiv;
213	newvar = newvar->suiv;
214	}
215	}
216	else
217	{
218	newvarprec = newvar;
219	newvar = newvar->suiv;
220	Globalite = 0;
221	}
222	}
223	if ( Globalite == 0 \|\| !newvar)
224	{
225	pos_end = setposcurname(fileout);
226	RemoveWordSET_0(fileout,oldposcuruse,
227	pos_end-oldposcuruse);
228
229	newvar = listin;
230	while ( newvar )
231	{
232	fprintf(fileout," USE %s, ONLY : %s \n",module,newvar->c_namevar);
233	newvar = newvar->suiv;
234	}
235	}
236	}
237
238
239	void Remove_Word_Contains_0()
240	{
241	if ( firstpass == 0 )
242	{
243	RemoveWordCUR_0(fortranout,(long)(-9),9);
244	}
245	}
246
247	void Remove_Word_end_module_0(int modulenamelength)
248	{
249	if ( firstpass == 0 )
250	{
251	RemoveWordCUR_0(fortranout,(long)(-modulenamelength-12),
252	modulenamelength+11);
253	}
254	}
255
256	void Write_Word_Contains_0()
257	{
258	if ( firstpass == 0 )
259	{
260	fprintf(fortranout,"\n contains\n");
261	}
262	}
263
264
265	void Write_Word_end_module_0()
266	{
267	if ( firstpass == 0 )
268	{
269	fprintf(fortranout,"\n end module %s",curmodulename);
270	}
271	}
272
273	void Add_Subroutine_For_Alloc(char *nom)
274	{
275	listnom *parcours;
276	listnom *newvar;
277	int out;
278
279	newvar = (listnom *)malloc(sizeof(listnom));
280	strcpy(newvar->o_nom,nom);
281	Save_Length(nom,23);
282	newvar->suiv = NULL;
283
284	if ( !List_Subroutine_For_Alloc )
285	{
286	List_Subroutine_For_Alloc = newvar;
287	}
288	else
289	{
290	parcours = List_Subroutine_For_Alloc;
291	out = 0 ;
292	while ( parcours->suiv && out == 0 )
293	{
294	if ( !strcasecmp(parcours->o_nom,nom) ) out = 1 ;
295	else parcours = parcours ->suiv;
296	}
297	/* */
298	if ( out == 0 )
299	{
300	if ( strcasecmp(parcours->o_nom,nom) ) parcours->suiv = newvar;
301	}
302	}
303	}
304
305
306	void Write_Alloc_Subroutine_0()
307	{
308	listnom *parcours_nom;
309	listnom *parcours_nomprec;
310	int out;
311	char ligne[LONG_C];
312
313	if ( firstpass == 0 )
314	{
315	parcours_nomprec = (listnom *)NULL;
316	parcours_nom = List_NameOfModule;
317	out = 0 ;
318	while ( parcours_nom && out == 0 )
319	{
320	/* */
321	if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1;
322	else parcours_nom = parcours_nom -> suiv;
323	}
324	if ( out == 1 )
325	{
326	if ( parcours_nom->o_val == 1 )
327	{
328	strcpy (ligne, "\n PUBLIC Alloc_agrif_");
329	strcat (ligne, curmodulename);
330	strcat (ligne, "\n");
331	convert2lower(ligne);
332	fprintf(fortranout,ligne);
333	}
334	}
335	Write_Word_Contains_0();
336	if ( out == 1 )
337	{
338	if ( parcours_nom->o_val == 1 )
339	{
340	sprintf (ligne, "Subroutine Alloc_agrif_%s(Agrif_Gr)",
341	curmodulename);
342	tofich(fortranout,ligne,1);
343	strcpy(ligne,"Use Agrif_Util");
344	tofich(fortranout,ligne,1);
345	strcpy (ligne, "Type(Agrif_grid), Pointer :: Agrif_Gr");
346	tofich(fortranout,ligne,1);
347	strcpy(ligne, "INTEGER :: i");
348	tofich (fortranout, ligne,1);
349	strcpy (ligne, "\n#include \"alloc_agrif_");
350	strcat (ligne, curmodulename);
351	strcat (ligne, ".h\"\n");
352	convert2lower(ligne);
353	fprintf(fortranout,ligne);
354	strcpy (ligne, "Return");
355	tofich(fortranout,ligne,1);
356	sprintf (ligne, "End Subroutine Alloc_agrif_%s",curmodulename);
357	tofich(fortranout,ligne,1);
358	/* List all Call Alloc_agrif_ */
359	Add_Subroutine_For_Alloc(curmodulename);
360	}
361	else
362	{
363	parcours_nom = List_Subroutine_For_Alloc;
364	out = 0;
365	while ( parcours_nom && out == 0 )
366	{
367	if ( !strcasecmp(parcours_nom->o_nom,curmodulename) ) out = 1;
368	else
369	{
370	parcours_nomprec = parcours_nom;
371	parcours_nom = parcours_nom->suiv;
372	}
373	}
374	if ( out == 1 )
375	{
376	if ( parcours_nom == List_Subroutine_For_Alloc)
377	{
378	List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv;
379	}
380	else
381	{
382	parcours_nomprec->suiv = parcours_nom->suiv;
383	parcours_nom = parcours_nomprec->suiv ;
384	}
385	}
386	}
387	}
388	}
389	}
390
391
392	void Write_Alloc_Subroutine_For_End_0()
393	{
394	listnom *parcours_nom;
395	listnom *parcours_nomprec;
396	int out;
397	char ligne[LONG_C];
398
399	if ( firstpass == 0 )
400	{
401	parcours_nomprec = (listnom *)NULL;
402	parcours_nom = List_NameOfModule;
403	out = 0 ;
404	while ( parcours_nom && out == 0 )
405	{
406	/* */
407	if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1;
408	else parcours_nom = parcours_nom -> suiv;
409	}
410	if ( out == 1 )
411	{
412	if ( parcours_nom->o_val == 1 )
413	{
414	strcpy (ligne, "\n PUBLIC Alloc_agrif_");
415	strcat (ligne, curmodulename);
416	strcat (ligne, "\n");
417	convert2lower(ligne);
418	fprintf(fortranout,ligne);
419	strcpy (ligne, "\n contains\n");
420	fprintf(fortranout,ligne);
421	sprintf (ligne, "Subroutine Alloc_agrif_%s(Agrif_Gr)",
422	curmodulename);
423	tofich(fortranout,ligne,1);
424	strcpy(ligne,"Use Agrif_Util");
425	tofich(fortranout,ligne,1);
426	strcpy (ligne, "Type(Agrif_grid), Pointer :: Agrif_Gr");
427	tofich(fortranout,ligne,1);
428	strcpy(ligne, "INTEGER :: i");
429	tofich (fortranout, ligne,1);
430	strcpy (ligne, "\n#include \"alloc_agrif_");
431	strcat (ligne, curmodulename);
432	strcat (ligne, ".h\"\n");
433	convert2lower(ligne);
434	fprintf(fortranout,ligne);
435	strcpy (ligne, "Return");
436	tofich(fortranout,ligne,1);
437	sprintf (ligne, "End Subroutine Alloc_agrif_%s",curmodulename);
438	tofich(fortranout,ligne,1);
439	/* List all Call Alloc_agrif */
440	Add_Subroutine_For_Alloc(parcours_nom->o_nom);
441	}
442	else
443	{
444	parcours_nom = List_Subroutine_For_Alloc;
445	out = 0;
446	while ( parcours_nom && out == 0 )
447	{
448	if ( !strcasecmp(parcours_nom->o_nom,curmodulename) ) out = 1;
449	else
450	{
451	parcours_nomprec = parcours_nom;
452	parcours_nom = parcours_nom->suiv;
453	}
454	}
455	if ( out == 1 )
456	{
457	if ( parcours_nom == List_Subroutine_For_Alloc)
458	{
459	List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv;
460	}
461	else
462	{
463	parcours_nomprec->suiv = parcours_nom->suiv;
464	parcours_nom = parcours_nomprec->suiv ;
465	}
466	}
467	}
468	}
469	}
470	}
471
472	void Write_GlobalParameter_Declaration_0()
473	{
474	listvar *parcours;
475
476	if ( firstpass == 0 )
477	{
478	parcours = List_GlobalParameter_Var;
479	while( parcours )
480	{
481	if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
482	{
483	writevardeclaration(parcours,module_declar,0,1);
484	}
485	parcours = parcours -> suiv;
486	}
487	}
488	}
489
490	void Write_GlobalType_Declaration_0()
491	{
492	listvar *parcours;
493	int out = 0;
494	int headtypewritten = 0;
495	char ligne[LONGNOM];
496	int changeval;
497
498	if ( firstpass == 0 )
499	{
500	parcours = List_Global_Var;
501	while( parcours )
502	{
503	if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
504	{
505	if (!strcasecmp(parcours->var->v_typevar,"type"))
506	{
507	out = 1;
508	if (headtypewritten == 0)
509	{
510	sprintf(ligne,"TYPE :: Agrif_%s",curmodulename);
511	tofich(module_declar,ligne,1);
512	headtypewritten = 1;
513	}
514	changeval = 0;
515	if (parcours->var->v_allocatable == 1)
516	{
517	changeval = 1;
518	parcours->var->v_allocatable = 0;
519	parcours->var->v_pointerdeclare = 1;
520	}
521	writevardeclaration(parcours,module_declar,0,0);
522	if (changeval == 1)
523	{
524	parcours->var->v_allocatable = 1;
525	parcours->var->v_pointerdeclare = 0;
526	}
527	}
528	}
529	parcours = parcours -> suiv;
530	}
531	if (out == 1)
532	{
533	sprintf(ligne,"END TYPE Agrif_%s",curmodulename);
534	tofich(module_declar,ligne,1);
535	sprintf(ligne,"TYPE(Agrif_%s), DIMENSION(:), ALLOCATABLE :: Agrif_%s_var",curmodulename,curmodulename);
536	tofich(module_declar,ligne,1);
537	}
538	}
539	}
540
541	void Write_NotGridDepend_Declaration_0()
542	{
543	listvar *parcours;
544
545	if ( firstpass == 0 )
546	{
547	parcours = List_NotGridDepend_Var;
548	while( parcours )
549	{
550	if ( !strcasecmp(parcours->var->v_modulename,curmodulename) )
551	{
552	writevardeclaration(parcours,fortranout,0,1);
553	}
554	parcours = parcours -> suiv;
555	}
556	}
557	}
558
559	/******************************************************************************/
560	/* IsTabvarsUseInArgument_0 */
561	/******************************************************************************/
562	/* Firstpass 1 */
563	/******************************************************************************/
564	/* */
565	/******************************************************************************/
566	int IsTabvarsUseInArgument_0()
567	{
568	int out;
569	int doloopout;
570	listvar *parcours;
571
572	out=1;
573
574	if ( List_UsedInSubroutine_Var )
575	{
576	doloopout = 0;
577	parcours = List_UsedInSubroutine_Var;
578	while ( parcours && doloopout == 0 )
579	{
580	if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) )
581	doloopout = 1;
582	else parcours = parcours->suiv;
583	}
584	if ( doloopout == 0 ) out = 0;
585	else out = 1 ;
586	}
587	else out = 0;
588
589	return out;
590	}
591
592
593	/******************************************************************************/
594	/* ImplicitNoneInSubroutine */
595	/******************************************************************************/
596	/* Firstpass 0 */
597	/******************************************************************************/
598	/* */
599	/******************************************************************************/
600	int ImplicitNoneInSubroutine()
601	{
602	listname *parcours;
603	int out;
604
605	parcours= List_ImplicitNoneSubroutine;
606	out = 0 ;
607	while ( parcours && out == 0 )
608	{
609	if ( !strcasecmp(parcours->n_name,subroutinename) ) out = 1;
610	else parcours = parcours->suiv;
611	}
612	return out;
613	}
614
615	/******************************************************************************/
616	/* Add_Pointer_Var_From_List_1 */
617	/******************************************************************************/
618	/* Firstpass 1 */
619	/******************************************************************************/
620	/* */
621	/******************************************************************************/
622	void Add_Pointer_Var_From_List_1(listvar *listin)
623	{
624	listvar *parcours;
625
626	if ( firstpass == 1 )
627	{
628	parcours = listin;
629	while ( parcours )
630	{
631	Add_Pointer_Var_1(parcours->var->v_nomvar);
632	parcours = parcours -> suiv ;
633	}
634	}
635	}
636
637	/******************************************************************************/
638	/* Add_Pointer_Var_1 */
639	/******************************************************************************/
640	/* Firstpass 1 */
641	/******************************************************************************/
642	/* */
643	/******************************************************************************/
644	void Add_Pointer_Var_1(char *nom)
645	{
646	listname *newvar;
647	listname *parcours;
648	int out;
649
650	if ( firstpass == 1 )
651	{
652	if ( !List_Pointer_Var )
653	{
654	newvar = (listname *)malloc(sizeof(listname));
655	strcpy(newvar->n_name,nom);
656	Save_Length(nom,20);
657	newvar->suiv = NULL;
658	List_Pointer_Var = newvar;
659	}
660	else
661	{
662	parcours = List_Pointer_Var;
663	out = 0 ;
664	while ( parcours->suiv && out == 0 )
665	{
666	if ( !strcasecmp(parcours->n_name,nom) ) out = 1;
667	else
668	parcours=parcours->suiv;
669	}
670	if ( out == 0 )
671	{
672	if ( !strcasecmp(parcours->n_name,nom) ) out = 1;
673	else
674	{
675	/* add the record */
676	newvar = (listname *)malloc(sizeof(listname));
677	strcpy(newvar->n_name,nom);
678	Save_Length(nom,20);
679	newvar->suiv = NULL;
680	parcours->suiv = newvar;
681	}
682	}
683	}
684	}
685	}
686
687	/******************************************************************************/
688	/* varispointer_0 */
689	/******************************************************************************/
690	/* Firstpass 0 */
691	/******************************************************************************/
692	/* */
693	/******************************************************************************/
694	int varispointer_0(char *ident)
695	{
696	listname *newname;
697	int out;
698
699	out =0;
700	if ( firstpass == 0 )
701	{
702	newname = List_Pointer_Var;
703	while( newname && out == 0 )
704	{
705	if ( !strcasecmp(ident,newname->n_name) ) out = 1 ;
706	else newname = newname->suiv;
707	}
708	}
709	return out;
710	}
711
712	/******************************************************************************/
713	/* varistyped_0 */
714	/******************************************************************************/
715	/* Firstpass 0 */
716	/******************************************************************************/
717	/* */
718	/******************************************************************************/
719	int varistyped_0(char *ident)
720	{
721	listvar *parcours;
722	int out;
723
724	out =0;
725	if ( firstpass == 0 )
726	{
727	parcours = List_Global_Var;
728	while( parcours && out == 0 )
729	{
730	if ( !strcasecmp(ident,parcours->var->v_nomvar) )
731	{
732	if (!strcasecmp(parcours->var->v_typevar,"type")) out = 1;
733	}
734	parcours = parcours->suiv;
735	}
736	}
737	return out;
738	}
739
740
741	/******************************************************************************/
742	/* VariableIsNotFunction */
743	/******************************************************************************/
744	/* */
745	/******************************************************************************/
746	int VariableIsNotFunction(char *ident)
747	{
748	int out;
749	listvar *newvar;
750
751	out =0;
752
753	if ( !strcasecmp(ident,"size") \|\|
754	!strcasecmp(ident,"if") \|\|
755	!strcasecmp(ident,"max") \|\|
756	!strcasecmp(ident,"min")
757	)
758	{
759	newvar = List_SubroutineDeclaration_Var;
760	while ( newvar && out == 0 )
761	{
762	if ( !strcasecmp(subroutinename, newvar->var->v_subroutinename) &&
763	!strcasecmp(ident, newvar->var->v_nomvar) ) out = 1;
764	newvar = newvar -> suiv ;
765	}
766	if ( out == 1 ) out = 0;
767	else out = 1;
768	/* if it has not been found */
769	if ( out == 1 )
770	{
771	out = 0;
772	newvar = List_Global_Var;
773	while ( newvar && out == 0 )
774	{
775	if ( !strcasecmp(ident, newvar->var->v_nomvar) ) out = 1;
776	newvar = newvar -> suiv ;
777	}
778	if ( out == 1 ) out = 0;
779	else out = 1;
780	}
781	}
782	/* */
783	return out;
784	}

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

Download in other formats: