Annotation of rpl/src/instructions_d2.c, revision 1.65
1.1 bertrand 1: /*
2: ================================================================================
1.64 bertrand 3: RPL/2 (R) version 4.1.32
1.65 ! 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.11 bertrand 23: #include "rpl-conv.h"
1.1 bertrand 24:
25:
26: /*
27: ================================================================================
28: Fonction 'd->r'
29: ================================================================================
30: Entrées : pointeur sur une structure struct_processus
31: --------------------------------------------------------------------------------
32: Sorties :
33: --------------------------------------------------------------------------------
34: Effets de bord : néant
35: ================================================================================
36: */
37:
38: void
39: instruction_d_vers_r(struct_processus *s_etat_processus)
40: {
41: struct_liste_chainee *l_element_courant;
42: struct_liste_chainee *l_element_precedent;
43:
44: struct_objet *s_copie_argument;
45: struct_objet *s_objet_argument;
46: struct_objet *s_objet_resultat;
47:
48: (*s_etat_processus).erreur_execution = d_ex;
49:
50: if ((*s_etat_processus).affichage_arguments == 'Y')
51: {
52: printf("\n D->R ");
53:
54: if ((*s_etat_processus).langue == 'F')
55: {
56: printf("(degrés vers radians)\n\n");
57: }
58: else
59: {
60: printf("(degrees to radians)\n\n");
61: }
62:
63: printf(" 1: %s, %s\n", d_INT, d_REL);
64: printf("-> 1: %s\n\n", d_REL);
65:
66: printf(" 1: %s, %s\n", d_NOM, d_ALG);
67: printf("-> 1: %s\n\n", d_ALG);
68:
69: printf(" 1: %s\n", d_RPN);
70: printf("-> 1: %s\n", d_RPN);
71:
72: return;
73: }
74: else if ((*s_etat_processus).test_instruction == 'Y')
75: {
76: (*s_etat_processus).nombre_arguments = -1;
77: return;
78: }
79:
80: if (test_cfsf(s_etat_processus, 31) == d_vrai)
81: {
82: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
83: {
84: return;
85: }
86: }
87:
88: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
89: &s_objet_argument) == d_erreur)
90: {
91: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
92: return;
93: }
94:
95: /*
96: --------------------------------------------------------------------------------
97: Conversion d'un entier ou d'un réel
98: --------------------------------------------------------------------------------
99: */
100:
101: if (((*s_objet_argument).type == INT) ||
102: ((*s_objet_argument).type == REL))
103: {
104: if ((s_objet_resultat = allocation(s_etat_processus, REL))
105: == NULL)
106: {
107: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
108: return;
109: }
110:
111: if ((*s_objet_argument).type == INT)
112: {
113: (*((real8 *) (*s_objet_resultat).objet)) =
114: (real8) (*((integer8 *) (*s_objet_argument).objet));
115: }
116: else
117: {
118: (*((real8 *) (*s_objet_resultat).objet)) =
119: (*((real8 *) (*s_objet_argument).objet));
120: }
121:
122: conversion_degres_vers_radians((real8 *) (*s_objet_resultat).objet);
123: }
124:
125: /*
126: --------------------------------------------------------------------------------
127: Conversion d'un nom
128: --------------------------------------------------------------------------------
129: */
130:
131: else if ((*s_objet_argument).type == NOM)
132: {
133: if ((s_objet_resultat = allocation(s_etat_processus, ALG))
134: == NULL)
135: {
136: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
137: return;
138: }
139:
140: if (((*s_objet_resultat).objet =
141: allocation_maillon(s_etat_processus)) == NULL)
142: {
143: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
144: return;
145: }
146:
147: l_element_courant = (*s_objet_resultat).objet;
148:
149: if (((*l_element_courant).donnee =
150: allocation(s_etat_processus, FCT)) == NULL)
151: {
152: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
153: return;
154: }
155:
156: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
157: .nombre_arguments = 0;
158: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
159: .fonction = instruction_vers_niveau_superieur;
160:
161: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
162: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
163: {
164: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
165: return;
166: }
167:
168: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
169: .nom_fonction, "<<");
170:
171: if (((*l_element_courant).suivant =
172: allocation_maillon(s_etat_processus)) == NULL)
173: {
174: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
175: return;
176: }
177:
178: l_element_courant = (*l_element_courant).suivant;
179: (*l_element_courant).donnee = s_objet_argument;
180:
181: if (((*l_element_courant).suivant =
182: allocation_maillon(s_etat_processus)) == NULL)
183: {
184: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
185: return;
186: }
187:
188: l_element_courant = (*l_element_courant).suivant;
189:
190: if (((*l_element_courant).donnee =
191: allocation(s_etat_processus, FCT)) == NULL)
192: {
193: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
194: return;
195: }
196:
197: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
198: .nombre_arguments = 1;
199: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
200: .fonction = instruction_d_vers_r;
201:
202: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
203: .nom_fonction = malloc(5 * sizeof(unsigned char))) == NULL)
204: {
205: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
206: return;
207: }
208:
209: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
210: .nom_fonction, "D->R");
211:
212: if (((*l_element_courant).suivant =
213: allocation_maillon(s_etat_processus)) == NULL)
214: {
215: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
216: return;
217: }
218:
219: l_element_courant = (*l_element_courant).suivant;
220:
221: if (((*l_element_courant).donnee =
222: allocation(s_etat_processus, FCT)) == NULL)
223: {
224: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
225: return;
226: }
227:
228: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
229: .nombre_arguments = 0;
230: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
231: .fonction = instruction_vers_niveau_inferieur;
232:
233: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
234: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
235: {
236: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
237: return;
238: }
239:
240: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
241: .nom_fonction, ">>");
242:
243: (*l_element_courant).suivant = NULL;
244: s_objet_argument = NULL;
245: }
246:
247: /*
248: --------------------------------------------------------------------------------
249: Conversion d'une expression
250: --------------------------------------------------------------------------------
251: */
252:
253: else if (((*s_objet_argument).type == ALG) ||
254: ((*s_objet_argument).type == RPN))
255: {
256: if ((s_copie_argument = copie_objet(s_etat_processus,
257: s_objet_argument, 'N')) == NULL)
258: {
259: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
260: return;
261: }
262:
263: l_element_courant = (struct_liste_chainee *)
264: (*s_copie_argument).objet;
265: l_element_precedent = l_element_courant;
266:
267: while((*l_element_courant).suivant != NULL)
268: {
269: l_element_precedent = l_element_courant;
270: l_element_courant = (*l_element_courant).suivant;
271: }
272:
273: if (((*l_element_precedent).suivant =
274: allocation_maillon(s_etat_processus)) == NULL)
275: {
276: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
277: return;
278: }
279:
280: if (((*(*l_element_precedent).suivant).donnee =
281: allocation(s_etat_processus, FCT)) == NULL)
282: {
283: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
284: return;
285: }
286:
287: (*((struct_fonction *) (*(*(*l_element_precedent).suivant)
288: .donnee).objet)).nombre_arguments = 1;
289: (*((struct_fonction *) (*(*(*l_element_precedent).suivant)
290: .donnee).objet)).fonction = instruction_d_vers_r;
291:
292: if (((*((struct_fonction *) (*(*(*l_element_precedent)
293: .suivant).donnee).objet)).nom_fonction =
294: malloc(5 * sizeof(unsigned char))) == NULL)
295: {
296: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
297: return;
298: }
299:
300: strcpy((*((struct_fonction *) (*(*(*l_element_precedent)
301: .suivant).donnee).objet)).nom_fonction, "D->R");
302:
303: (*(*l_element_precedent).suivant).suivant = l_element_courant;
304:
305: s_objet_resultat = s_copie_argument;
306: }
307:
308: /*
309: --------------------------------------------------------------------------------
310: Réalisation impossible de la fonction R->D
311: --------------------------------------------------------------------------------
312: */
313:
314: else
315: {
316: liberation(s_etat_processus, s_objet_argument);
317:
318: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
319: return;
320: }
321:
322: liberation(s_etat_processus, s_objet_argument);
323:
324: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
325: s_objet_resultat) == d_erreur)
326: {
327: return;
328: }
329:
330: return;
331: }
332:
333:
334: /*
335: ================================================================================
336: Fonction 'det'
337: ================================================================================
338: Entrées : pointeur sur une structure struct_processus
339: --------------------------------------------------------------------------------
340: Sorties :
341: --------------------------------------------------------------------------------
342: Effets de bord : néant
343: ================================================================================
344: */
345:
346: void
347: instruction_det(struct_processus *s_etat_processus)
348: {
349: struct_objet *s_objet_argument;
350: struct_objet *s_objet_resultat;
351:
352: (*s_etat_processus).erreur_execution = d_ex;
353:
354: if ((*s_etat_processus).affichage_arguments == 'Y')
355: {
356: printf("\n DET ");
357:
358: if ((*s_etat_processus).langue == 'F')
359: {
360: printf("(déterminant)\n\n");
361: }
362: else
363: {
364: printf("(determinant)\n\n");
365: }
366:
367: printf(" 1: %s\n", d_MIN);
368: printf("-> 1: %s, %s\n\n", d_INT, d_REL);
369:
370: printf(" 1: %s\n", d_MRL);
371: printf("-> 1: %s\n\n", d_REL);
372:
373: printf(" 1: %s\n", d_MCX);
374: printf("-> 1: %s\n", d_CPL);
375:
376: return;
377: }
378: else if ((*s_etat_processus).test_instruction == 'Y')
379: {
380: (*s_etat_processus).nombre_arguments = -1;
381: return;
382: }
383:
384: if (test_cfsf(s_etat_processus, 31) == d_vrai)
385: {
386: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
387: {
388: return;
389: }
390: }
391:
392: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
393: &s_objet_argument) == d_erreur)
394: {
395: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
396: return;
397: }
398:
399: /*
400: --------------------------------------------------------------------------------
401: L'argument est une matrice carrée
402: --------------------------------------------------------------------------------
403: */
404:
405: if (((*s_objet_argument).type == MIN) ||
406: ((*s_objet_argument).type == MRL))
407: {
408: if ((*((struct_matrice *) (*s_objet_argument).objet)).nombre_lignes !=
409: (*((struct_matrice *) (*s_objet_argument).objet))
410: .nombre_colonnes)
411: {
412: liberation(s_etat_processus, s_objet_argument);
413:
414: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
415: return;
416: }
417:
418: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
419: {
420: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
421: return;
422: }
423:
424: determinant(s_etat_processus, (struct_matrice *)
425: (*s_objet_argument).objet, (*s_objet_resultat).objet);
426:
427: if ((*s_etat_processus).erreur_systeme != d_es)
428: {
429: return;
430: }
431:
432: if (((*s_etat_processus).exception != d_ep) ||
433: ((*s_etat_processus).erreur_execution != d_ex))
434: {
435: liberation(s_etat_processus, s_objet_resultat);
436: liberation(s_etat_processus, s_objet_argument);
437: return;
438: }
439: }
440: else if ((*s_objet_argument).type == MCX)
441: {
442: if ((*((struct_matrice *) (*s_objet_argument).objet)).nombre_lignes !=
443: (*((struct_matrice *) (*s_objet_argument).objet))
444: .nombre_colonnes)
445: {
446: liberation(s_etat_processus, s_objet_argument);
447:
448: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
449: return;
450: }
451:
452: if ((s_objet_resultat = allocation(s_etat_processus, CPL)) == NULL)
453: {
454: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
455: return;
456: }
457:
458: determinant(s_etat_processus, (struct_matrice *)
459: (*s_objet_argument).objet,
460: ((complex16 *) (*s_objet_resultat).objet));
461:
462: if ((*s_etat_processus).erreur_systeme != d_es)
463: {
464: return;
465: }
466:
467: if (((*s_etat_processus).exception != d_ep) ||
468: ((*s_etat_processus).erreur_execution != d_ex))
469: {
470: liberation(s_etat_processus, s_objet_resultat);
471: liberation(s_etat_processus, s_objet_argument);
472: return;
473: }
474: }
475:
476: /*
477: --------------------------------------------------------------------------------
478: Type incompatible avec la fonction déterminant
479: --------------------------------------------------------------------------------
480: */
481:
482: else
483: {
484: liberation(s_etat_processus, s_objet_argument);
485:
486: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
487: return;
488: }
489:
490: liberation(s_etat_processus, s_objet_argument);
491:
492: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
493: s_objet_resultat) == d_erreur)
494: {
495: return;
496: }
497:
498: return;
499: }
500:
501:
502: /*
503: ================================================================================
504: Fonction 'dot'
505: ================================================================================
506: Entrées : pointeur sur une structure struct_processus
507: --------------------------------------------------------------------------------
508: Sorties :
509: --------------------------------------------------------------------------------
510: Effets de bord : néant
511: ================================================================================
512: */
513:
514: void
515: instruction_dot(struct_processus *s_etat_processus)
516: {
517: integer8 cumul;
518: integer8 tampon;
519:
520: logical1 depassement;
521: logical1 erreur_memoire;
522:
523: struct_objet *s_objet_argument_1;
524: struct_objet *s_objet_argument_2;
525: struct_objet *s_objet_resultat;
526:
1.41 bertrand 527: integer8 i;
1.1 bertrand 528:
529: void *accumulateur;
530:
531: (*s_etat_processus).erreur_execution = d_ex;
532:
533: if ((*s_etat_processus).affichage_arguments == 'Y')
534: {
535: printf("\n DOT ");
536:
537: if ((*s_etat_processus).langue == 'F')
538: {
539: printf("(produit scalaire)\n\n");
540: }
541: else
542: {
543: printf("(scalar product)\n\n");
544: }
545:
546: printf(" 2: %s\n", d_VIN);
547: printf(" 1: %s\n", d_VIN);
548: printf("-> 1: %s, %s\n\n", d_INT, d_REL);
549:
550: printf(" 2: %s, %s\n", d_VIN, d_VRL);
551: printf(" 1: %s, %s\n", d_VIN, d_VRL);
552: printf("-> 1: %s\n\n", d_REL);
553:
554: printf(" 2: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
555: printf(" 1: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
556: printf("-> 1: %s\n\n", d_CPL);
557:
558: return;
559: }
560: else if ((*s_etat_processus).test_instruction == 'Y')
561: {
562: (*s_etat_processus).nombre_arguments = -1;
563: return;
564: }
565:
566: if (test_cfsf(s_etat_processus, 31) == d_vrai)
567: {
568: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
569: {
570: return;
571: }
572: }
573:
574: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
575: &s_objet_argument_1) == d_erreur)
576: {
577: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
578: return;
579: }
580:
581: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
582: &s_objet_argument_2) == d_erreur)
583: {
584: liberation(s_etat_processus, s_objet_argument_1);
585:
586: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
587: return;
588: }
589:
590: /*
591: --------------------------------------------------------------------------------
592: Résultat entier
593: --------------------------------------------------------------------------------
594: */
595:
596: if (((*s_objet_argument_1).type == VIN) &&
597: ((*s_objet_argument_2).type == VIN))
598: {
599: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
600: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
601: {
602: liberation(s_etat_processus, s_objet_argument_1);
603: liberation(s_etat_processus, s_objet_argument_2);
604:
605: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
606: return;
607: }
608:
609: if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
610: {
611: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
612: return;
613: }
614:
615: (*((integer8 *) (*s_objet_resultat).objet)) = 0;
616: depassement = d_faux;
617:
618: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
619: .taille; i++)
620: {
621: if (depassement_multiplication(&(((integer8 *) (*((struct_vecteur *)
622: (*s_objet_argument_1).objet)).tableau)[i]),
623: &(((integer8 *) (*((struct_vecteur *) (*s_objet_argument_2)
624: .objet)).tableau)[i]), &tampon) == d_erreur)
625: {
626: depassement = d_vrai;
627: break;
628: }
629:
630: if (depassement_addition((integer8 *) (*s_objet_resultat).objet,
631: &tampon, &cumul) == d_erreur)
632: {
633: depassement = d_vrai;
634: break;
635: }
636:
637: (*((integer8 *) (*s_objet_resultat).objet)) = cumul;
638: }
639:
640: if (depassement == d_vrai)
641: {
642: free((*s_objet_resultat).objet);
643: (*s_objet_resultat).type = REL;
644:
645: if (((*s_objet_resultat).objet = malloc(sizeof(real8))) == NULL)
646: {
647: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
648: return;
649: }
650:
1.41 bertrand 651: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
652: (*s_objet_argument_1).objet)).taille) * sizeof(real8)))
1.1 bertrand 653: == NULL)
654: {
655: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
656: return;
657: }
658:
659: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
660: .taille; i++)
661: {
662: ((real8 *) accumulateur)[i] = (real8) ((integer8 *)
663: (*((struct_vecteur *) (*s_objet_argument_1)
664: .objet)).tableau)[i] * (real8) ((integer8 *)
665: (*((struct_vecteur *) (*s_objet_argument_2).objet))
666: .tableau)[i];
667: }
668:
669: (*((real8 *) (*s_objet_resultat).objet)) = sommation_vecteur_reel(
670: accumulateur, &((*((struct_vecteur *) (*s_objet_argument_1)
671: .objet)).taille), &erreur_memoire);
672:
673: if (erreur_memoire == d_vrai)
674: {
675: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
676: return;
677: }
678:
679: free(accumulateur);
680: }
681: }
682:
683: /*
684: --------------------------------------------------------------------------------
685: Résultat réel
686: --------------------------------------------------------------------------------
687: */
688:
689: else if (((*s_objet_argument_1).type == VIN) &&
690: ((*s_objet_argument_2).type == VRL))
691: {
692: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
693: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
694: {
695: liberation(s_etat_processus, s_objet_argument_1);
696: liberation(s_etat_processus, s_objet_argument_2);
697:
698: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
699: return;
700: }
701:
702: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
703: {
704: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
705: return;
706: }
707:
1.41 bertrand 708: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
709: (*s_objet_argument_1).objet)).taille) * sizeof(real8))) == NULL)
1.1 bertrand 710: {
711: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
712: return;
713: }
714:
715: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
716: .taille; i++)
717: {
1.41 bertrand 718: ((real8 *) accumulateur)[i] = ((real8)
1.1 bertrand 719: ((integer8 *) (*((struct_vecteur *) (*s_objet_argument_1)
1.41 bertrand 720: .objet)).tableau)[i]) * ((real8 *) (*((struct_vecteur *)
1.1 bertrand 721: (*s_objet_argument_2).objet)).tableau)[i];
722: }
723:
724: (*((real8 *) (*s_objet_resultat).objet)) = sommation_vecteur_reel(
725: accumulateur, &((*((struct_vecteur *) (*s_objet_argument_1)
726: .objet)).taille), &erreur_memoire);
727:
728: if (erreur_memoire == d_vrai)
729: {
730: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
731: return;
732: }
733:
734: free(accumulateur);
735: }
736: else if (((*s_objet_argument_1).type == VRL) &&
737: ((*s_objet_argument_2).type == VIN))
738: {
739: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
740: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
741: {
742: liberation(s_etat_processus, s_objet_argument_1);
743: liberation(s_etat_processus, s_objet_argument_2);
744:
745: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
746: return;
747: }
748:
749: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
750: {
751: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
752: return;
753: }
754:
1.41 bertrand 755: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
756: (*s_objet_argument_1).objet)).taille) * sizeof(real8))) == NULL)
1.1 bertrand 757: {
758: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
759: return;
760: }
761:
762: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
763: .taille; i++)
764: {
765: ((real8 *) accumulateur)[i] =
766: ((real8 *) (*((struct_vecteur *) (*s_objet_argument_1)
1.41 bertrand 767: .objet)).tableau)[i] * ((real8) ((integer8 *)
768: (*((struct_vecteur *)(*s_objet_argument_2).objet))
769: .tableau)[i]);
1.1 bertrand 770: }
771:
772: (*((real8 *) (*s_objet_resultat).objet)) = sommation_vecteur_reel(
773: accumulateur, &((*((struct_vecteur *) (*s_objet_argument_1)
774: .objet)).taille), &erreur_memoire);
775:
776: if (erreur_memoire == d_vrai)
777: {
778: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
779: return;
780: }
781:
782: free(accumulateur);
783: }
784: else if (((*s_objet_argument_1).type == VRL) &&
785: ((*s_objet_argument_2).type == VRL))
786: {
787: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
788: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
789: {
790: liberation(s_etat_processus, s_objet_argument_1);
791: liberation(s_etat_processus, s_objet_argument_2);
792:
793: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
794: return;
795: }
796:
797: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
798: {
799: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
800: return;
801: }
802:
1.41 bertrand 803: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
804: (*s_objet_argument_1).objet)).taille) * sizeof(real8))) == NULL)
1.1 bertrand 805: {
806: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
807: return;
808: }
809:
810: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
811: .taille; i++)
812: {
813: ((real8 *) accumulateur)[i] =
814: ((real8 *) (*((struct_vecteur *) (*s_objet_argument_1)
815: .objet)).tableau)[i] * ((real8 *) (*((struct_vecteur *)
816: (*s_objet_argument_2).objet)).tableau)[i];
817: }
818:
819: (*((real8 *) (*s_objet_resultat).objet)) = sommation_vecteur_reel(
820: accumulateur, &((*((struct_vecteur *) (*s_objet_argument_1)
821: .objet)).taille), &erreur_memoire);
822:
823: if (erreur_memoire == d_vrai)
824: {
825: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
826: return;
827: }
828:
829: free(accumulateur);
830: }
831:
832: /*
833: --------------------------------------------------------------------------------
834: Résultat complexe
835: --------------------------------------------------------------------------------
836: */
837:
838: else if (((*s_objet_argument_1).type == VCX) &&
839: ((*s_objet_argument_2).type == VIN))
840: {
841: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
842: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
843: {
844: liberation(s_etat_processus, s_objet_argument_1);
845: liberation(s_etat_processus, s_objet_argument_2);
846:
847: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
848: return;
849: }
850:
851: if ((s_objet_resultat = allocation(s_etat_processus, CPL)) == NULL)
852: {
853: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
854: return;
855: }
856:
1.41 bertrand 857: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
858: (*s_objet_argument_1).objet)).taille) * sizeof(complex16)))
1.1 bertrand 859: == NULL)
860: {
861: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
862: return;
863: }
864:
865: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
866: .taille; i++)
867: {
868: f77multiplicationci_(&(((struct_complexe16 *) (*((struct_vecteur *)
869: (*s_objet_argument_1).objet)).tableau)[i]),
870: &(((integer8 *) (*((struct_vecteur *) (*s_objet_argument_2)
871: .objet)).tableau)[i]), &(((complex16 *) accumulateur)[i]));
872: }
873:
874: (*((complex16 *) (*s_objet_resultat).objet)) =
875: sommation_vecteur_complexe(accumulateur,
876: &((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille),
877: &erreur_memoire);
878:
879: if (erreur_memoire == d_vrai)
880: {
881: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
882: return;
883: }
884:
885: free(accumulateur);
886: }
887: else if (((*s_objet_argument_1).type == VCX) &&
888: ((*s_objet_argument_2).type == VRL))
889: {
890: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
891: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
892: {
893: liberation(s_etat_processus, s_objet_argument_1);
894: liberation(s_etat_processus, s_objet_argument_2);
895:
896: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
897: return;
898: }
899:
900: if ((s_objet_resultat = allocation(s_etat_processus, CPL)) == NULL)
901: {
902: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
903: return;
904: }
905:
1.41 bertrand 906: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
907: (*s_objet_argument_1).objet)).taille) * sizeof(complex16)))
1.1 bertrand 908: == NULL)
909: {
910: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
911: return;
912: }
913:
914: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
915: .taille; i++)
916: {
917: f77multiplicationcr_(&(((struct_complexe16 *) (*((struct_vecteur *)
918: (*s_objet_argument_1).objet)).tableau)[i]),
919: &(((real8 *) (*((struct_vecteur *) (*s_objet_argument_2)
920: .objet)).tableau)[i]), &(((complex16 *) accumulateur)[i]));
921: }
922:
923: (*((complex16 *) (*s_objet_resultat).objet)) =
924: sommation_vecteur_complexe(accumulateur,
925: &((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille),
926: &erreur_memoire);
927:
928: if (erreur_memoire == d_vrai)
929: {
930: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
931: return;
932: }
933:
934: free(accumulateur);
935: }
936: else if (((*s_objet_argument_1).type == VCX) &&
937: ((*s_objet_argument_2).type == VCX))
938: {
939: /*
940: * s_argument_2 est conjugué avant d'effectuer le produit
941: */
942:
943: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
944: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
945: {
946: liberation(s_etat_processus, s_objet_argument_1);
947: liberation(s_etat_processus, s_objet_argument_2);
948:
949: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
950: return;
951: }
952:
953: if ((s_objet_resultat = allocation(s_etat_processus, CPL)) == NULL)
954: {
955: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
956: return;
957: }
958:
1.41 bertrand 959: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
960: (*s_objet_argument_1).objet)).taille) * sizeof(complex16)))
1.1 bertrand 961: == NULL)
962: {
963: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
964: return;
965: }
966:
967: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
968: .taille; i++)
969: {
970: ((struct_complexe16 *) (*((struct_vecteur *) (*s_objet_argument_2)
971: .objet)).tableau)[i].partie_imaginaire =
972: -((struct_complexe16 *) (*((struct_vecteur *)
973: (*s_objet_argument_2).objet)).tableau)[i].partie_imaginaire;
974:
975: f77multiplicationcc_(&(((struct_complexe16 *) (*((struct_vecteur *)
976: (*s_objet_argument_2).objet)).tableau)[i]),
977: &(((struct_complexe16 *) (*((struct_vecteur *)
978: (*s_objet_argument_1).objet)).tableau)[i]),
979: &(((complex16 *) accumulateur)[i]));
980: }
981:
982: (*((complex16 *) (*s_objet_resultat).objet)) =
983: sommation_vecteur_complexe(accumulateur,
984: &((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille),
985: &erreur_memoire);
986:
987: if (erreur_memoire == d_vrai)
988: {
989: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
990: return;
991: }
992:
993: free(accumulateur);
994: }
995: else if (((*s_objet_argument_1).type == VRL) &&
996: ((*s_objet_argument_2).type == VCX))
997: {
998: /*
999: * s_argument_2 est conjugué avant d'effectuer le produit
1000: */
1001:
1002: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
1003: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
1004: {
1005: liberation(s_etat_processus, s_objet_argument_1);
1006: liberation(s_etat_processus, s_objet_argument_2);
1007:
1008: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
1009: return;
1010: }
1011:
1012: if ((s_objet_resultat = allocation(s_etat_processus, CPL)) == NULL)
1013: {
1014: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1015: return;
1016: }
1017:
1.41 bertrand 1018: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
1019: (*s_objet_argument_1).objet)).taille) * sizeof(complex16)))
1.1 bertrand 1020: == NULL)
1021: {
1022: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1023: return;
1024: }
1025:
1026: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
1027: .taille; i++)
1028: {
1029: ((struct_complexe16 *) (*((struct_vecteur *) (*s_objet_argument_2)
1030: .objet)).tableau)[i].partie_imaginaire =
1031: -((struct_complexe16 *) (*((struct_vecteur *)
1032: (*s_objet_argument_2).objet)).tableau)[i].partie_imaginaire;
1033:
1034: f77multiplicationcr_(&(((struct_complexe16 *) (*((struct_vecteur *)
1035: (*s_objet_argument_2).objet)).tableau)[i]),
1036: &(((real8 *) (*((struct_vecteur *) (*s_objet_argument_1)
1037: .objet)).tableau)[i]), &(((complex16 *) accumulateur)[i]));
1038: }
1039:
1040: (*((complex16 *) (*s_objet_resultat).objet)) =
1041: sommation_vecteur_complexe(accumulateur,
1042: &((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille),
1043: &erreur_memoire);
1044:
1045: if (erreur_memoire == d_vrai)
1046: {
1047: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1048: return;
1049: }
1050:
1051: free(accumulateur);
1052: }
1053: else if (((*s_objet_argument_1).type == VIN) &&
1054: ((*s_objet_argument_2).type == VCX))
1055: {
1056: /*
1057: * s_argument_2 est conjugué avant d'effectuer le produit
1058: */
1059:
1060: if ((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille !=
1061: (*((struct_vecteur *) (*s_objet_argument_2).objet)).taille)
1062: {
1063: liberation(s_etat_processus, s_objet_argument_1);
1064: liberation(s_etat_processus, s_objet_argument_2);
1065:
1066: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
1067: return;
1068: }
1069:
1070: if ((s_objet_resultat = allocation(s_etat_processus, CPL)) == NULL)
1071: {
1072: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1073: return;
1074: }
1075:
1.41 bertrand 1076: if ((accumulateur = malloc(((size_t) (*((struct_vecteur *)
1077: (*s_objet_argument_1).objet)).taille) * sizeof(complex16)))
1.1 bertrand 1078: == NULL)
1079: {
1080: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1081: return;
1082: }
1083:
1084: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument_1).objet))
1085: .taille; i++)
1086: {
1087: ((struct_complexe16 *) (*((struct_vecteur *) (*s_objet_argument_2)
1088: .objet)).tableau)[i].partie_imaginaire =
1089: -((struct_complexe16 *) (*((struct_vecteur *)
1090: (*s_objet_argument_2).objet)).tableau)[i].partie_imaginaire;
1091:
1092: f77multiplicationci_(&(((struct_complexe16 *) (*((struct_vecteur *)
1093: (*s_objet_argument_2).objet)).tableau)[i]),
1094: &(((integer8 *) (*((struct_vecteur *) (*s_objet_argument_1)
1095: .objet)).tableau)[i]), &(((complex16 *) accumulateur)[i]));
1096: }
1097:
1098: (*((complex16 *) (*s_objet_resultat).objet)) =
1099: sommation_vecteur_complexe(accumulateur,
1100: &((*((struct_vecteur *) (*s_objet_argument_1).objet)).taille),
1101: &erreur_memoire);
1102:
1103: if (erreur_memoire == d_vrai)
1104: {
1105: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1106: return;
1107: }
1108:
1109: free(accumulateur);
1110: }
1111:
1112: /*
1113: --------------------------------------------------------------------------------
1114: Types d'objets incompatibles avec le calcul d'un produit scalaire
1115: --------------------------------------------------------------------------------
1116: */
1117:
1118: else
1119: {
1120: liberation(s_etat_processus, s_objet_argument_1);
1121: liberation(s_etat_processus, s_objet_argument_2);
1122:
1123: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1124: return;
1125: }
1126:
1127: liberation(s_etat_processus, s_objet_argument_1);
1128: liberation(s_etat_processus, s_objet_argument_2);
1129:
1130: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1131: s_objet_resultat) == d_erreur)
1132: {
1133: return;
1134: }
1135:
1136: return;
1137: }
1138:
1139: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instructions_d2.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src