Annotation of rpl/src/sommations.c, revision 1.68
1.1 bertrand 1: /*
2: ================================================================================
1.67 bertrand 3: RPL/2 (R) version 4.1.32
1.68 ! bertrand 4: Copyright (C) 1989-2020 Dr. BERTRAND Joël
1.1 bertrand 5:
6: This file is part of RPL/2.
7:
8: RPL/2 is free software; you can redistribute it and/or modify it
9: under the terms of the CeCILL V2 License as published by the french
10: CEA, CNRS and INRIA.
11:
12: RPL/2 is distributed in the hope that it will be useful, but WITHOUT
13: ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14: FITNESS FOR A PARTICULAR PURPOSE. See the CeCILL V2 License
15: for more details.
16:
17: You should have received a copy of the CeCILL License
18: along with RPL/2. If not, write to info@cecill.info.
19: ================================================================================
20: */
21:
22:
1.12 bertrand 23: #include "rpl-conv.h"
1.1 bertrand 24:
25:
26: /*
27: ================================================================================
28: Fonction réalisation le tri d'un vecteur de réels du plus petit au plus
29: grand en valeur absolue (algorithme de tri dit de Shell-Metzner)
30: ================================================================================
31: Entrées : pointeur sur une structure struct_processus
32: --------------------------------------------------------------------------------
33: Sorties :
34: --------------------------------------------------------------------------------
35: Effets de bord : néant
36: ================================================================================
37: */
38:
39: void
1.43 bertrand 40: tri_vecteur(real8 *vecteur, integer8 taille)
1.1 bertrand 41: {
42: logical1 terminaison_boucle_1;
43: logical1 terminaison_boucle_2;
44: logical1 terminaison_boucle_3;
45:
1.11 bertrand 46: real8 registre;
47:
1.43 bertrand 48: integer8 ecartement;
49: integer8 indice_i;
50: integer8 indice_j;
51: integer8 indice_k;
52: integer8 indice_l;
1.1 bertrand 53:
54: ecartement = taille;
55: terminaison_boucle_1 = d_faux;
56:
57: do
58: {
59: ecartement = ecartement / 2;
60:
61: if (ecartement >= 1)
62: {
63: indice_j = 0;
64: indice_k = taille - ecartement;
65: terminaison_boucle_2 = d_faux;
66:
67: do
68: {
69: indice_i = indice_j;
70: terminaison_boucle_3 = d_faux;
71:
72: do
73: {
74: indice_l = indice_i + ecartement;
75:
76: if ((indice_i > 0) && (indice_l > 0))
77: {
1.42 bertrand 78: if (abs(vecteur[indice_i - 1]) >
79: abs(vecteur[indice_l - 1]))
1.1 bertrand 80: {
1.11 bertrand 81: registre = vecteur[indice_i - 1];
82: vecteur[indice_i - 1] = vecteur[indice_l - 1];
83: vecteur[indice_l - 1] = registre;
1.1 bertrand 84:
85: indice_i -= ecartement;
86:
87: if (indice_i < 1)
88: {
89: terminaison_boucle_3 = d_vrai;
90: }
91: }
92: else
93: {
94: terminaison_boucle_3 = d_vrai;
95: }
96: }
97: else
98: {
99: terminaison_boucle_3 = d_vrai;
100: }
101: } while(terminaison_boucle_3 == d_faux);
102:
103: indice_j++;
104:
105: if (indice_j > indice_k)
106: {
107: terminaison_boucle_2 = d_vrai;
108: }
109: } while(terminaison_boucle_2 == d_faux);
110: }
111: else
112: {
113: terminaison_boucle_1 = d_vrai;
114: }
115: } while(terminaison_boucle_1 == d_faux);
116: }
117:
118:
119: /*
120: ================================================================================
121: Fonction réalisation la sommation d'un vecteur de réel sans perte
122: de précision
123: ================================================================================
124: Entrées : pointeur sur une structure struct_processus
125: --------------------------------------------------------------------------------
126: Sorties :
127: --------------------------------------------------------------------------------
128: Effets de bord : néant
129: ================================================================================
130: */
131:
132: real8
1.43 bertrand 133: sommation_vecteur_reel(real8 *vecteur, integer8 *taille,
1.1 bertrand 134: logical1 *erreur_memoire)
135: {
136: #if 0
137: unsigned long nombre_elements;
138: unsigned long pointeur;
139:
140: /*
141: * Sommation des termes en commençant par le plus petit.
142: * Algorithme optimal mais NP-complet...
143: */
144:
145: nombre_elements = (*taille);
146: (*erreur_memoire) = d_faux;
147:
148: while(nombre_elements != 1)
149: {
150: pointeur = (*taille) - nombre_elements;
151: tri_vecteur(&(vecteur[pointeur]), nombre_elements);
152: vecteur[pointeur + 1] += vecteur[pointeur];
153: nombre_elements--;
154: }
155:
156: return(vecteur[(*taille) - 1]);
157: #else
158: real8 erreur;
159: real8 somme;
160: real8 registre;
161: real8 tampon;
162:
1.43 bertrand 163: integer8 i;
1.1 bertrand 164:
165: somme = 0;
166: erreur = 0;
167:
168: (*erreur_memoire) = d_faux;
169:
170: for(i = 0; i < (*taille); i++)
171: {
172: tampon = somme;
173: registre = vecteur[i] + erreur;
174: somme = tampon + registre;
175: erreur = (tampon - somme) + registre;
176: }
177:
178: return(somme);
179: #endif
180: }
181:
182:
183: /*
184: ================================================================================
185: Fonction réalisation la sommation d'un vecteur de complexes sans perte
186: de précision
187: ================================================================================
188: Entrées : pointeur sur une structure struct_processus
189: --------------------------------------------------------------------------------
190: Sorties :
191: --------------------------------------------------------------------------------
192: Effets de bord : néant
193: ================================================================================
194: */
195:
196: complex16
1.43 bertrand 197: sommation_vecteur_complexe(complex16 *vecteur, integer8 *taille,
1.1 bertrand 198: logical1 *erreur_memoire)
199: {
200: complex16 cumul;
201:
202: real8 *tampon;
203:
1.43 bertrand 204: integer8 i;
205: integer8 nombre_elements;
1.1 bertrand 206:
1.53 bertrand 207: if ((tampon = sys_malloc(((size_t) (*taille)) * sizeof(real8))) == NULL)
1.1 bertrand 208: {
209: (*erreur_memoire) = d_vrai;
210:
211: cumul.partie_reelle = 0;
212: cumul.partie_imaginaire = 0;
213:
214: return(cumul);
215: }
216:
217: (*erreur_memoire) = d_faux;
218:
219: /*
220: * Sommation des termes en commençant par le plus petit
221: */
222:
223: for(i = 0, nombre_elements = (*taille); i < nombre_elements;
224: tampon[i] = vecteur[i].partie_reelle, i++);
225:
226: cumul.partie_reelle = sommation_vecteur_reel(tampon, taille,
227: erreur_memoire);
228:
229: /*
230: * Même traitement, mais sur la partie imaginaire
231: */
232:
233: for(i = 0, nombre_elements = (*taille); i < nombre_elements;
234: tampon[i] = vecteur[i].partie_imaginaire, i++);
235:
236: cumul.partie_imaginaire = sommation_vecteur_reel(tampon, taille,
237: erreur_memoire);
238:
1.53 bertrand 239: sys_free(tampon);
1.1 bertrand 240:
241: return(cumul);
242: }
243:
244: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sommations.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src