1: /*
2: ================================================================================
3: RPL/2 (R) version 4.1.36
4: Copyright (C) 1989-2025 Dr. BERTRAND Joël
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:
23: #include "rpl-conv.h"
24:
25:
26: /*
27: ================================================================================
28: Fonction 'gegvl'
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_gegvl(struct_processus *s_etat_processus)
40: {
41: struct_objet *s_objet_argument_1;
42: struct_objet *s_objet_argument_2;
43: struct_objet *s_objet_resultat;
44:
45: (*s_etat_processus).erreur_execution = d_ex;
46:
47: if ((*s_etat_processus).affichage_arguments == 'Y')
48: {
49: printf("\n GEGVL ");
50:
51: if ((*s_etat_processus).langue == 'F')
52: {
53: printf("(valeurs propres généralisées)\n\n");
54: }
55: else
56: {
57: printf("(generalized eigenvalues)\n\n");
58: }
59:
60: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
61: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
62: printf("-> 1: %s\n", d_VCX);
63:
64: return;
65: }
66: else if ((*s_etat_processus).test_instruction == 'Y')
67: {
68: (*s_etat_processus).nombre_arguments = -1;
69: return;
70: }
71:
72: if (test_cfsf(s_etat_processus, 31) == d_vrai)
73: {
74: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
75: {
76: return;
77: }
78: }
79:
80: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
81: &s_objet_argument_1) == d_erreur)
82: {
83: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
84: return;
85: }
86:
87: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
88: &s_objet_argument_2) == d_erreur)
89: {
90: liberation(s_etat_processus, s_objet_argument_1);
91:
92: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
93: return;
94: }
95:
96: /*
97: --------------------------------------------------------------------------------
98: Les arguments sont des matrices carrées de mêmes dimensions
99: --------------------------------------------------------------------------------
100: */
101:
102: if ((((*s_objet_argument_1).type == MIN) ||
103: ((*s_objet_argument_1).type == MRL) ||
104: ((*s_objet_argument_1).type == MCX)) &&
105: (((*s_objet_argument_2).type == MIN) ||
106: ((*s_objet_argument_2).type == MRL) ||
107: ((*s_objet_argument_2).type == MCX)))
108: {
109: if (((*((struct_matrice *) (*s_objet_argument_1).objet)).nombre_lignes
110: != (*((struct_matrice *) (*s_objet_argument_1).objet))
111: .nombre_colonnes) || ((*((struct_matrice *)
112: (*s_objet_argument_2).objet)).nombre_lignes !=
113: (*((struct_matrice *) (*s_objet_argument_2).objet))
114: .nombre_colonnes) || ((*((struct_matrice *)
115: (*s_objet_argument_1).objet)).nombre_lignes !=
116: (*((struct_matrice *) (*s_objet_argument_2).objet))
117: .nombre_lignes))
118: {
119: liberation(s_etat_processus, s_objet_argument_1);
120: liberation(s_etat_processus, s_objet_argument_2);
121:
122: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
123: return;
124: }
125:
126: if ((s_objet_resultat = allocation(s_etat_processus, VCX)) == NULL)
127: {
128: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
129: return;
130: }
131:
132: valeurs_propres_generalisees(s_etat_processus,
133: (struct_matrice *) (*s_objet_argument_2).objet,
134: (struct_matrice *) (*s_objet_argument_1).objet,
135: (struct_vecteur *) (*s_objet_resultat).objet,
136: NULL, NULL);
137:
138: if ((*s_etat_processus).erreur_systeme != d_ex)
139: {
140: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
141: return;
142: }
143:
144: if (((*s_etat_processus).exception != d_ep) ||
145: ((*s_etat_processus).erreur_execution != d_ex))
146: {
147: liberation(s_etat_processus, s_objet_argument_1);
148: liberation(s_etat_processus, s_objet_argument_2);
149: liberation(s_etat_processus, s_objet_resultat);
150: return;
151: }
152: }
153:
154: /*
155: --------------------------------------------------------------------------------
156: Type incompatible
157: --------------------------------------------------------------------------------
158: */
159:
160: else
161: {
162: liberation(s_etat_processus, s_objet_argument_1);
163: liberation(s_etat_processus, s_objet_argument_2);
164:
165: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
166: return;
167: }
168:
169: liberation(s_etat_processus, s_objet_argument_1);
170: liberation(s_etat_processus, s_objet_argument_2);
171:
172: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
173: s_objet_resultat) == d_erreur)
174: {
175: return;
176: }
177:
178: return;
179: }
180:
181:
182: /*
183: ================================================================================
184: Fonction 'gegv'
185: ================================================================================
186: Entrées : pointeur sur une structure struct_processus
187: --------------------------------------------------------------------------------
188: Sorties :
189: --------------------------------------------------------------------------------
190: Effets de bord : néant
191: ================================================================================
192: */
193:
194: void
195: instruction_gegv(struct_processus *s_etat_processus)
196: {
197: struct_objet *s_objet_argument_1;
198: struct_objet *s_objet_argument_2;
199: struct_objet *s_objet_resultat_1;
200: struct_objet *s_objet_resultat_2;
201: struct_objet *s_objet_resultat_3;
202:
203: (*s_etat_processus).erreur_execution = d_ex;
204:
205: if ((*s_etat_processus).affichage_arguments == 'Y')
206: {
207: printf("\n GEGV ");
208:
209: if ((*s_etat_processus).langue == 'F')
210: {
211: printf("(valeurs et vecteurs propres généralisés)\n\n");
212: }
213: else
214: {
215: printf("(generalized eigenvalues and eigenvectors)\n\n");
216: }
217:
218: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
219: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
220: printf("-> 3: %s\n", d_MCX);
221: printf(" 2: %s\n", d_MCX);
222: printf(" 1: %s\n", d_VCX);
223:
224: return;
225: }
226: else if ((*s_etat_processus).test_instruction == 'Y')
227: {
228: (*s_etat_processus).nombre_arguments = -1;
229: return;
230: }
231:
232: if (test_cfsf(s_etat_processus, 31) == d_vrai)
233: {
234: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
235: {
236: return;
237: }
238: }
239:
240: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
241: &s_objet_argument_1) == d_erreur)
242: {
243: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
244: return;
245: }
246:
247: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
248: &s_objet_argument_2) == d_erreur)
249: {
250: liberation(s_etat_processus, s_objet_argument_1);
251:
252: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
253: return;
254: }
255:
256: /*
257: --------------------------------------------------------------------------------
258: Les arguments sont des matrices carrées de mêmes dimensions
259: --------------------------------------------------------------------------------
260: */
261:
262: if ((((*s_objet_argument_1).type == MIN) ||
263: ((*s_objet_argument_1).type == MRL) ||
264: ((*s_objet_argument_1).type == MCX)) &&
265: (((*s_objet_argument_2).type == MIN) ||
266: ((*s_objet_argument_2).type == MRL) ||
267: ((*s_objet_argument_2).type == MCX)))
268: {
269: if (((*((struct_matrice *) (*s_objet_argument_1).objet)).nombre_lignes
270: != (*((struct_matrice *) (*s_objet_argument_1).objet))
271: .nombre_colonnes) || ((*((struct_matrice *)
272: (*s_objet_argument_2).objet)).nombre_lignes !=
273: (*((struct_matrice *) (*s_objet_argument_2).objet))
274: .nombre_colonnes) || ((*((struct_matrice *)
275: (*s_objet_argument_1).objet)).nombre_lignes !=
276: (*((struct_matrice *) (*s_objet_argument_2).objet))
277: .nombre_lignes))
278: {
279: liberation(s_etat_processus, s_objet_argument_1);
280: liberation(s_etat_processus, s_objet_argument_2);
281:
282: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
283: return;
284: }
285:
286: if ((s_objet_resultat_1 = allocation(s_etat_processus, VCX)) == NULL)
287: {
288: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
289: return;
290: }
291:
292: if ((s_objet_resultat_2 = allocation(s_etat_processus, MCX)) == NULL)
293: {
294: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
295: return;
296: }
297:
298: if ((s_objet_resultat_3 = allocation(s_etat_processus, MCX)) == NULL)
299: {
300: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
301: return;
302: }
303:
304: valeurs_propres_generalisees(s_etat_processus,
305: (struct_matrice *) (*s_objet_argument_2).objet,
306: (struct_matrice *) (*s_objet_argument_1).objet,
307: (struct_vecteur *) (*s_objet_resultat_1).objet,
308: (struct_matrice *) (*s_objet_resultat_3).objet,
309: (struct_matrice *) (*s_objet_resultat_2).objet);
310:
311: if ((*s_etat_processus).erreur_systeme != d_es)
312: {
313: return;
314: }
315:
316: if (((*s_etat_processus).exception != d_ep) ||
317: ((*s_etat_processus).erreur_execution != d_ex))
318: {
319: liberation(s_etat_processus, s_objet_argument_1);
320: liberation(s_etat_processus, s_objet_argument_2);
321: liberation(s_etat_processus, s_objet_resultat_1);
322: liberation(s_etat_processus, s_objet_resultat_2);
323: liberation(s_etat_processus, s_objet_resultat_3);
324:
325: return;
326: }
327: }
328:
329: /*
330: --------------------------------------------------------------------------------
331: Type incompatible
332: --------------------------------------------------------------------------------
333: */
334:
335: else
336: {
337: liberation(s_etat_processus, s_objet_argument_1);
338: liberation(s_etat_processus, s_objet_argument_2);
339:
340: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
341: return;
342: }
343:
344: liberation(s_etat_processus, s_objet_argument_1);
345: liberation(s_etat_processus, s_objet_argument_2);
346:
347: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
348: s_objet_resultat_3) == d_erreur)
349: {
350: return;
351: }
352:
353: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
354: s_objet_resultat_2) == d_erreur)
355: {
356: return;
357: }
358:
359: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
360: s_objet_resultat_1) == d_erreur)
361: {
362: return;
363: }
364:
365: return;
366: }
367:
368:
369: /*
370: ================================================================================
371: Fonction 'glegv'
372: ================================================================================
373: Entrées : pointeur sur une structure struct_processus
374: --------------------------------------------------------------------------------
375: Sorties :
376: --------------------------------------------------------------------------------
377: Effets de bord : néant
378: ================================================================================
379: */
380:
381: void
382: instruction_glegv(struct_processus *s_etat_processus)
383: {
384: struct_objet *s_objet_argument_1;
385: struct_objet *s_objet_argument_2;
386: struct_objet *s_objet_resultat_1;
387: struct_objet *s_objet_resultat_2;
388:
389: (*s_etat_processus).erreur_execution = d_ex;
390:
391: if ((*s_etat_processus).affichage_arguments == 'Y')
392: {
393: printf("\n GLEGV ");
394:
395: if ((*s_etat_processus).langue == 'F')
396: {
397: printf("(valeurs et vecteurs propres gauches généralisés)\n\n");
398: }
399: else
400: {
401: printf("(generalized eigenvalues and left eigenvectors)\n\n");
402: }
403:
404: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
405: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
406: printf("-> 2: %s\n", d_MCX);
407: printf(" 1: %s\n", d_VCX);
408:
409: return;
410: }
411: else if ((*s_etat_processus).test_instruction == 'Y')
412: {
413: (*s_etat_processus).nombre_arguments = -1;
414: return;
415: }
416:
417: if (test_cfsf(s_etat_processus, 31) == d_vrai)
418: {
419: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
420: {
421: return;
422: }
423: }
424:
425: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
426: &s_objet_argument_1) == d_erreur)
427: {
428: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
429: return;
430: }
431:
432: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
433: &s_objet_argument_2) == d_erreur)
434: {
435: liberation(s_etat_processus, s_objet_argument_1);
436:
437: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
438: return;
439: }
440:
441: /*
442: --------------------------------------------------------------------------------
443: Les arguments sont des matrices carrées de mêmes dimensions
444: --------------------------------------------------------------------------------
445: */
446:
447: if ((((*s_objet_argument_1).type == MIN) ||
448: ((*s_objet_argument_1).type == MRL) ||
449: ((*s_objet_argument_1).type == MCX)) &&
450: (((*s_objet_argument_2).type == MIN) ||
451: ((*s_objet_argument_2).type == MRL) ||
452: ((*s_objet_argument_2).type == MCX)))
453: {
454: if (((*((struct_matrice *) (*s_objet_argument_1).objet)).nombre_lignes
455: != (*((struct_matrice *) (*s_objet_argument_1).objet))
456: .nombre_colonnes) || ((*((struct_matrice *)
457: (*s_objet_argument_2).objet)).nombre_lignes !=
458: (*((struct_matrice *) (*s_objet_argument_2).objet))
459: .nombre_colonnes) || ((*((struct_matrice *)
460: (*s_objet_argument_1).objet)).nombre_lignes !=
461: (*((struct_matrice *) (*s_objet_argument_2).objet))
462: .nombre_lignes))
463: {
464: liberation(s_etat_processus, s_objet_argument_1);
465: liberation(s_etat_processus, s_objet_argument_2);
466:
467: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
468: return;
469: }
470:
471: if ((s_objet_resultat_1 = allocation(s_etat_processus, VCX)) == NULL)
472: {
473: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
474: return;
475: }
476:
477: if ((s_objet_resultat_2 = allocation(s_etat_processus, MCX)) == NULL)
478: {
479: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
480: return;
481: }
482:
483: valeurs_propres_generalisees(s_etat_processus,
484: (struct_matrice *) (*s_objet_argument_2).objet,
485: (struct_matrice *) (*s_objet_argument_1).objet,
486: (struct_vecteur *) (*s_objet_resultat_1).objet,
487: (struct_matrice *) (*s_objet_resultat_2).objet,
488: NULL);
489:
490: if ((*s_etat_processus).erreur_systeme != d_es)
491: {
492: return;
493: }
494:
495: if (((*s_etat_processus).exception != d_ep) ||
496: ((*s_etat_processus).erreur_execution != d_ex))
497: {
498: liberation(s_etat_processus, s_objet_argument_1);
499: liberation(s_etat_processus, s_objet_argument_2);
500: liberation(s_etat_processus, s_objet_resultat_1);
501: liberation(s_etat_processus, s_objet_resultat_2);
502:
503: return;
504: }
505: }
506:
507: /*
508: --------------------------------------------------------------------------------
509: Type incompatible
510: --------------------------------------------------------------------------------
511: */
512:
513: else
514: {
515: liberation(s_etat_processus, s_objet_argument_1);
516: liberation(s_etat_processus, s_objet_argument_2);
517:
518: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
519: return;
520: }
521:
522: liberation(s_etat_processus, s_objet_argument_1);
523: liberation(s_etat_processus, s_objet_argument_2);
524:
525: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
526: s_objet_resultat_2) == d_erreur)
527: {
528: return;
529: }
530:
531: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
532: s_objet_resultat_1) == d_erreur)
533: {
534: return;
535: }
536:
537: return;
538: }
539:
540:
541: /*
542: ================================================================================
543: Fonction 'gregv'
544: ================================================================================
545: Entrées : pointeur sur une structure struct_processus
546: --------------------------------------------------------------------------------
547: Sorties :
548: --------------------------------------------------------------------------------
549: Effets de bord : néant
550: ================================================================================
551: */
552:
553: void
554: instruction_gregv(struct_processus *s_etat_processus)
555: {
556: struct_objet *s_objet_argument_1;
557: struct_objet *s_objet_argument_2;
558: struct_objet *s_objet_resultat_1;
559: struct_objet *s_objet_resultat_2;
560:
561: (*s_etat_processus).erreur_execution = d_ex;
562:
563: if ((*s_etat_processus).affichage_arguments == 'Y')
564: {
565: printf("\n GREGV ");
566:
567: if ((*s_etat_processus).langue == 'F')
568: {
569: printf("(valeurs et vecteurs propres droits généralisés)\n\n");
570: }
571: else
572: {
573: printf("(generalized eigenvalues and right eigenvectors)\n\n");
574: }
575:
576: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
577: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
578: printf("-> 2: %s\n", d_MCX);
579: printf(" 1: %s\n", d_VCX);
580:
581: return;
582: }
583: else if ((*s_etat_processus).test_instruction == 'Y')
584: {
585: (*s_etat_processus).nombre_arguments = -1;
586: return;
587: }
588:
589: if (test_cfsf(s_etat_processus, 31) == d_vrai)
590: {
591: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
592: {
593: return;
594: }
595: }
596:
597: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
598: &s_objet_argument_1) == d_erreur)
599: {
600: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
601: return;
602: }
603:
604: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
605: &s_objet_argument_2) == d_erreur)
606: {
607: liberation(s_etat_processus, s_objet_argument_1);
608:
609: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
610: return;
611: }
612:
613: /*
614: --------------------------------------------------------------------------------
615: Les arguments sont des matrices carrées de mêmes dimensions
616: --------------------------------------------------------------------------------
617: */
618:
619: if ((((*s_objet_argument_1).type == MIN) ||
620: ((*s_objet_argument_1).type == MRL) ||
621: ((*s_objet_argument_1).type == MCX)) &&
622: (((*s_objet_argument_2).type == MIN) ||
623: ((*s_objet_argument_2).type == MRL) ||
624: ((*s_objet_argument_2).type == MCX)))
625: {
626: if (((*((struct_matrice *) (*s_objet_argument_1).objet)).nombre_lignes
627: != (*((struct_matrice *) (*s_objet_argument_1).objet))
628: .nombre_colonnes) || ((*((struct_matrice *)
629: (*s_objet_argument_2).objet)).nombre_lignes !=
630: (*((struct_matrice *) (*s_objet_argument_2).objet))
631: .nombre_colonnes) || ((*((struct_matrice *)
632: (*s_objet_argument_1).objet)).nombre_lignes !=
633: (*((struct_matrice *) (*s_objet_argument_2).objet))
634: .nombre_lignes))
635: {
636: liberation(s_etat_processus, s_objet_argument_1);
637: liberation(s_etat_processus, s_objet_argument_2);
638:
639: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
640: return;
641: }
642:
643: if ((s_objet_resultat_1 = allocation(s_etat_processus, VCX)) == NULL)
644: {
645: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
646: return;
647: }
648:
649: if ((s_objet_resultat_2 = allocation(s_etat_processus, MCX)) == NULL)
650: {
651: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
652: return;
653: }
654:
655: valeurs_propres_generalisees(s_etat_processus,
656: (struct_matrice *) (*s_objet_argument_2).objet,
657: (struct_matrice *) (*s_objet_argument_1).objet,
658: (struct_vecteur *) (*s_objet_resultat_1).objet,
659: NULL,
660: (struct_matrice *) (*s_objet_resultat_2).objet);
661:
662: if ((*s_etat_processus).erreur_systeme != d_es)
663: {
664: return;
665: }
666:
667: if (((*s_etat_processus).exception != d_ep) ||
668: ((*s_etat_processus).erreur_execution != d_ex))
669: {
670: /*
671: * Problème dans la diagonalisation
672: */
673:
674: liberation(s_etat_processus, s_objet_argument_1);
675: liberation(s_etat_processus, s_objet_argument_2);
676: liberation(s_etat_processus, s_objet_resultat_1);
677: liberation(s_etat_processus, s_objet_resultat_2);
678:
679: return;
680: }
681: }
682:
683: /*
684: --------------------------------------------------------------------------------
685: Type incompatible
686: --------------------------------------------------------------------------------
687: */
688:
689: else
690: {
691: liberation(s_etat_processus, s_objet_argument_1);
692: liberation(s_etat_processus, s_objet_argument_2);
693:
694: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
695: return;
696: }
697:
698: liberation(s_etat_processus, s_objet_argument_1);
699: liberation(s_etat_processus, s_objet_argument_2);
700:
701: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
702: s_objet_resultat_2) == d_erreur)
703: {
704: return;
705: }
706:
707: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
708: s_objet_resultat_1) == d_erreur)
709: {
710: return;
711: }
712:
713: return;
714: }
715:
716: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>