1 /*
2 cast.c -- Cast types.
3
4 Copyright (C) 1994-2003 K. Scott Hunziker.
5 Copyright (C) 1990-1994 The Boeing Company.
6
7 See the file COPYING for license, warranty, and permission details.
8 */
9
10 static char rcsid[] =
11 "$Id: cast.c,v 1.7 2003/12/06 04:42:58 ksh Exp $";
12
13 #include "cast.h"
14 #include "entity.h"
15 #include "scalar.h"
16 #include "vector.h"
17 #include "matrix.h"
18 #include "two_type.h"
19 #include "real.h"
20 #include "dense.h"
21 #include "datum.h"
22
23 extern DATUM *num_digits;
24 #define DIGITS datum_to_int (num_digits)
25
26 ENTITY *
bi_integer(p)27 bi_integer (p)
28 ENTITY *p;
29 {
30 EASSERT (p, 0, 0);
31
32 return (cast_entity (p, integer));
33 }
34
35 ENTITY *
cast_entity(ip,type)36 cast_entity (ip, type)
37 ENTITY *ip;
38 TYPE type;
39 {
40 EASSERT (ip, 0, 0);
41
42 switch (ip->class)
43 {
44 case scalar:
45 return (cast_scalar ((SCALAR *) ip, type));
46 case vector:
47 return (cast_vector ((VECTOR *) ip, type));
48 case matrix:
49 return (cast_matrix ((MATRIX *) ip, type));
50 default:
51 BAD_CLASS (ip->class);
52 delete_entity (ip);
53 raise_exception ();
54 }
55 }
56
57 ENTITY *
cast_scalar(ips,type)58 cast_scalar (ips, type)
59 SCALAR *ips;
60 TYPE type;
61 {
62 EASSERT (ips, scalar, 0);
63
64 switch (TWO_TYPE (ips->type, type))
65 {
66
67 case integer_integer:
68 return (ENT (ips));
69 case integer_real:
70 return (cast_scalar_integer_real (ips));
71 case integer_complex:
72 return (cast_scalar_integer_complex (ips));
73 case integer_character:
74 return (cast_scalar_integer_character (ips));
75
76 case real_integer:
77 return (cast_scalar_real_integer (ips));
78 case real_real:
79 return (ENT (ips));
80 case real_complex:
81 return (cast_scalar_real_complex (ips));
82 case real_character:
83 return (cast_scalar_real_character (ips));
84
85 case complex_integer:
86 return (cast_scalar_complex_integer (ips));
87 case complex_real:
88 return (cast_scalar_complex_real (ips));
89 case complex_complex:
90 return (ENT (ips));
91 case complex_character:
92 return (cast_scalar_complex_character (ips));
93
94 case character_character:
95 return (ENT (ips));
96 default:
97 fail ("Can't cast scalar from \"%s\" to \"%s\".",
98 type_string[ips->type], type_string[type]);
99 }
100 delete_entity (ENT (ips));
101 raise_exception ();
102 }
103
104 ENTITY *
cast_vector(ipv,type)105 cast_vector (ipv, type)
106 VECTOR *ipv;
107 TYPE type;
108 {
109 EASSERT (ipv, vector, 0);
110
111 switch (TWO_TYPE (ipv->type, type))
112 {
113 case integer_integer:
114 return (ENT (ipv));
115 case integer_real:
116 return (cast_vector_integer_real (ipv));
117 case integer_complex:
118 return (cast_vector_integer_complex (ipv));
119 case integer_character:
120 return (cast_vector_integer_character (ipv));
121 case real_integer:
122 return (cast_vector_real_integer (ipv));
123 case real_real:
124 return (ENT (ipv));
125 case real_complex:
126 return (cast_vector_real_complex (ipv));
127 case real_character:
128 return (cast_vector_real_character (ipv));
129 case complex_integer:
130 return (cast_vector_complex_integer (ipv));
131 case complex_real:
132 return (cast_vector_complex_real (ipv));
133 case complex_complex:
134 return (ENT (ipv));
135 case complex_character:
136 return (cast_vector_complex_character (ipv));
137 case character_character:
138 return (ENT (ipv));
139 default:
140 fail ("Can't cast vector from \"%s\" to \"%s\".",
141 type_string[ipv->type], type_string[type]);
142 }
143 delete_entity (ENT (ipv));
144 raise_exception ();
145 }
146
147 ENTITY *
cast_matrix(ipm,type)148 cast_matrix (ipm, type)
149 MATRIX *ipm;
150 TYPE type;
151 {
152 EASSERT (ipm, matrix, 0);
153
154 switch (TWO_TYPE (ipm->type, type))
155 {
156 case integer_integer:
157 return (ENT (ipm));
158 case integer_real:
159 return (cast_matrix_integer_real (ipm));
160 case integer_complex:
161 return (cast_matrix_integer_complex (ipm));
162 case integer_character:
163 return (cast_matrix_integer_character (ipm));
164 case real_integer:
165 return (cast_matrix_real_integer (ipm));
166 case real_real:
167 return (ENT (ipm));
168 case real_complex:
169 return (cast_matrix_real_complex (ipm));
170 case real_character:
171 return (cast_matrix_real_character (ipm));
172 case complex_integer:
173 return (cast_matrix_complex_integer (ipm));
174 case complex_real:
175 return (cast_matrix_complex_real (ipm));
176 case complex_complex:
177 return (ENT (ipm));
178 case complex_character:
179 return (cast_matrix_complex_character (ipm));
180 case character_character:
181 return (ENT (ipm));
182 default:
183 fail ("Can't cast matrix from \"%s\" to \"%s\".",
184 type_string[ipm->type], type_string[type]);
185 }
186 delete_entity (ENT (ipm));
187 raise_exception ();
188 }
189
190 ENTITY *
cast_scalar_integer_real(ips)191 cast_scalar_integer_real (ips)
192 SCALAR *ips;
193 {
194 SCALAR *s;
195
196 EASSERT (ips, scalar, integer);
197
198 s = (SCALAR *) dup_scalar (ips);
199 s->v.real = (REAL) s->v.integer;
200 s->type = real;
201 return (ENT (s));
202 }
203
204 ENTITY *
cast_scalar_integer_complex(ips)205 cast_scalar_integer_complex (ips)
206 SCALAR *ips;
207 {
208 SCALAR *s;
209
210 EASSERT (ips, scalar, integer);
211
212 s = (SCALAR *) dup_scalar (ips);
213 s->v.complex.real = (REAL) s->v.integer;
214 s->v.complex.imag = 0;
215 s->type = complex;
216 return (ENT (s));
217 }
218
219 ENTITY *
cast_scalar_integer_character(p)220 cast_scalar_integer_character (p)
221 SCALAR *p;
222 {
223 SCALAR *s;
224
225 EASSERT (p, scalar, integer);
226
227 s = (SCALAR *) dup_scalar (p);
228 #if HAVE_SNPRINTF
229 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%d", s->v.integer)
230 >= PRINTF_BUF_SIZE)
231 {
232 fail ("Overflow in sprintf buffer.");
233 raise_exception ();
234 }
235 #else
236 sprintf (printf_buf, "%d", s->v.integer);
237 #endif
238 s->v.character = dup_char (printf_buf);
239 s->type = character;
240 return (ENT (s));
241 }
242
243 ENTITY *
cast_scalar_real_integer(ips)244 cast_scalar_real_integer (ips)
245 SCALAR *ips;
246 {
247 SCALAR *s;
248
249 EASSERT (ips, scalar, real);
250
251 s = (SCALAR *) dup_scalar (ips);
252 s->v.integer = (int) round (s->v.real);
253 s->type = integer;
254 return (ENT (s));
255 }
256
257 ENTITY *
cast_scalar_real_complex(ips)258 cast_scalar_real_complex (ips)
259 SCALAR *ips;
260 {
261 SCALAR *s;
262
263 EASSERT (ips, scalar, real);
264
265 s = (SCALAR *) dup_scalar (ips);
266 s->v.complex.real = (REAL) s->v.real;
267 s->v.complex.imag = 0;
268 s->type = complex;
269 return (ENT (s));
270 }
271
272 ENTITY *
cast_scalar_real_character(p)273 cast_scalar_real_character (p)
274 SCALAR *p;
275 {
276 SCALAR *s;
277
278 EASSERT (p, scalar, real);
279
280 s = (SCALAR *) dup_scalar (p);
281 #if HAVE_SNPRINTF
282 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%#.*g", DIGITS, s->v.real)
283 >= PRINTF_BUF_SIZE)
284 {
285 fail ("Overflow in sprintf buffer.");
286 raise_exception ();
287 }
288 #else
289 sprintf (printf_buf, "%#.*g", DIGITS, s->v.real);
290 #endif
291 s->v.character = dup_char (printf_buf);
292 s->type = character;
293 return (ENT (s));
294 }
295
296 ENTITY *
cast_scalar_complex_integer(ips)297 cast_scalar_complex_integer (ips)
298 SCALAR *ips;
299 {
300 SCALAR *s;
301
302 EASSERT (ips, scalar, complex);
303
304 s = (SCALAR *) dup_scalar (ips);
305 s->v.integer = (int) round (s->v.complex.real);
306 s->type = integer;
307 return (ENT (s));
308 }
309
310 ENTITY *
cast_scalar_complex_real(ips)311 cast_scalar_complex_real (ips)
312 SCALAR *ips;
313 {
314 SCALAR *s;
315
316 EASSERT (ips, scalar, complex);
317
318 s = (SCALAR *) dup_scalar (ips);
319 s->v.real = s->v.complex.real;
320 s->type = real;
321 return (ENT (s));
322 }
323
324 ENTITY *
cast_scalar_complex_character(p)325 cast_scalar_complex_character (p)
326 SCALAR *p;
327 {
328 SCALAR *s;
329
330 EASSERT (p, scalar, complex);
331
332 s = (SCALAR *) dup_scalar (p);
333 #if HAVE_SNPRINTF
334 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%#.*g + %#.*g*i",
335 DIGITS, s->v.complex.real,
336 DIGITS, s->v.complex.imag) >= PRINTF_BUF_SIZE)
337 {
338 fail ("Overflow in sprintf buffer.");
339 raise_exception ();
340 }
341 #else
342 sprintf (printf_buf, "%#.*g + %#.*g*i",
343 DIGITS, s->v.complex.real, DIGITS, s->v.complex.imag);
344 #endif
345 s->v.character = dup_char (printf_buf);
346 s->type = character;
347 return (ENT (s));
348 }
349
350 ENTITY *
cast_scalar_character_integer(ips)351 cast_scalar_character_integer (ips)
352 SCALAR *ips;
353 {
354 SCALAR *s;
355 int i;
356
357 EASSERT (ips, scalar, character);
358
359 i = *ips->v.character;
360 s = (SCALAR *) dup_scalar (ips);
361 FREE_CHAR (s->v.character);
362 s->v.integer = i;
363 s->type = integer;
364 return (ENT (s));
365 }
366
367 ENTITY *
cast_scalar_character_real(ips)368 cast_scalar_character_real (ips)
369 SCALAR *ips;
370 {
371 detour ("No code for `cast_scalar_character_real'.");
372 delete_entity (ENT (ips));
373 raise_exception ();
374 }
375
376 ENTITY *
cast_scalar_character_complex(ips)377 cast_scalar_character_complex (ips)
378 SCALAR *ips;
379 {
380 detour ("No code for `cast_scalar_character_complex'.");
381 delete_entity (ENT (ips));
382 raise_exception ();
383 }
384
385 ENTITY *
cast_vector_integer_real(ipv)386 cast_vector_integer_real (ipv)
387 VECTOR *ipv;
388 {
389 VECTOR *v;
390 int i;
391
392 EASSERT (ipv, vector, integer);
393
394 v = (VECTOR *) form_vector (ipv->ne, real, ipv->density);
395 if (ipv->eid != NULL)
396 v->eid = copy_entity (ipv->eid);
397 if (ipv->ja != NULL)
398 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
399
400 v->nn = ipv->nn;
401 if (ipv->a.integer != NULL)
402 {
403 if (v->a.real == NULL)
404 v->a.real = E_MALLOC (v->nn, real);
405 for (i = 0; i < v->nn; i++)
406 v->a.real[i] = (REAL) ipv->a.integer[i];
407 }
408
409 delete_entity (ENT (ipv));
410 return (ENT (v));
411 }
412
413 ENTITY *
cast_vector_integer_complex(ipv)414 cast_vector_integer_complex (ipv)
415 VECTOR *ipv;
416 {
417 VECTOR *v;
418 int i;
419
420 EASSERT (ipv, vector, integer);
421
422 v = (VECTOR *) form_vector (ipv->ne, complex, ipv->density);
423 if (ipv->eid != NULL)
424 v->eid = copy_entity (ipv->eid);
425 if (ipv->ja != NULL)
426 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
427
428 v->nn = ipv->nn;
429 if (ipv->a.integer != NULL)
430 {
431 if (v->a.complex == NULL)
432 v->a.complex = E_MALLOC (v->nn, complex);
433 for (i = 0; i < v->nn; i++)
434 {
435 v->a.complex[i].real = (REAL) ipv->a.integer[i];
436 v->a.complex[i].imag = 0.0;
437 }
438 }
439
440 delete_vector (ipv);
441 return (ENT (v));
442 }
443
444 ENTITY *
cast_vector_integer_character(ipv)445 cast_vector_integer_character (ipv)
446 VECTOR *ipv;
447 {
448 VECTOR *v;
449 int i;
450
451 EASSERT (ipv, vector, integer);
452
453 ipv = (VECTOR *) dense_vector (ipv);
454
455 v = (VECTOR *) form_vector (ipv->ne, character, ipv->density);
456 if (ipv->eid != NULL)
457 v->eid = copy_entity (ipv->eid);
458 if (ipv->ja != NULL)
459 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
460
461 v->nn = ipv->nn;
462 if (v->nn > 0)
463 {
464 if (v->a.character == NULL)
465 v->a.character = E_MALLOC (v->nn, character);
466 for (i = 0; i < v->nn; i++)
467 {
468 #if HAVE_SNPRINTF
469 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%d", ipv->a.integer[i])
470 >= PRINTF_BUF_SIZE)
471 {
472 fail ("Overflow in sprintf buffer.");
473 raise_exception ();
474 }
475 #else
476 sprintf (printf_buf, "%d", ipv->a.integer[i]);
477 #endif
478 v->a.character[i] = dup_char (printf_buf);
479 }
480 }
481
482 delete_vector (ipv);
483 return (ENT (v));
484 }
485
486 ENTITY *
cast_vector_real_integer(ipv)487 cast_vector_real_integer (ipv)
488 VECTOR *ipv;
489 {
490 VECTOR *v;
491 int i;
492
493 EASSERT (ipv, vector, real);
494
495 v = (VECTOR *) form_vector (ipv->ne, integer, ipv->density);
496 if (ipv->eid != NULL)
497 v->eid = copy_entity (ipv->eid);
498 if (ipv->ja != NULL)
499 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
500
501 v->nn = ipv->nn;
502 if (ipv->a.real != NULL)
503 {
504 if (v->a.integer == NULL)
505 v->a.integer = E_MALLOC (v->nn, integer);
506 for (i = 0; i < v->nn; i++)
507 v->a.integer[i] = (int) round (ipv->a.real[i]);
508 }
509
510 delete_entity (ENT (ipv));
511 return (ENT (v));
512 }
513
514 ENTITY *
cast_vector_real_complex(ipv)515 cast_vector_real_complex (ipv)
516 VECTOR *ipv;
517 {
518 VECTOR *v;
519 int i;
520
521 EASSERT (ipv, vector, real);
522
523 v = (VECTOR *) form_vector (ipv->ne, complex, ipv->density);
524 if (ipv->eid != NULL)
525 v->eid = copy_entity (ipv->eid);
526 if (ipv->ja != NULL)
527 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
528
529 v->nn = ipv->nn;
530 if (ipv->a.real != NULL)
531 {
532 if (v->a.complex == NULL)
533 v->a.complex = E_MALLOC (v->nn, complex);
534 for (i = 0; i < v->nn; i++)
535 {
536 v->a.complex[i].real = ipv->a.real[i];
537 v->a.complex[i].imag = 0.0;
538 }
539 }
540
541 delete_vector (ipv);
542 return (ENT (v));
543 }
544
545 ENTITY *
cast_vector_real_character(ipv)546 cast_vector_real_character (ipv)
547 VECTOR *ipv;
548 {
549 VECTOR *v;
550 int i;
551 int d = DIGITS;
552
553 EASSERT (ipv, vector, real);
554
555 ipv = (VECTOR *) dense_vector (ipv);
556
557 v = (VECTOR *) form_vector (ipv->ne, character, ipv->density);
558 if (ipv->eid != NULL)
559 v->eid = copy_entity (ipv->eid);
560 if (ipv->ja != NULL)
561 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
562
563 v->nn = ipv->nn;
564 if (v->nn > 0)
565 {
566 if (v->a.character == NULL)
567 v->a.character = E_MALLOC (v->nn, character);
568 for (i = 0; i < v->nn; i++)
569 {
570 #if HAVE_SNPRINTF
571 if (snprintf (printf_buf, PRINTF_BUF_SIZE,
572 "%#.*g", d, ipv->a.real[i])
573 >= PRINTF_BUF_SIZE)
574 {
575 fail ("Overflow in sprintf buffer.");
576 raise_exception ();
577 }
578 #else
579 sprintf (printf_buf, "%#.*g", d, ipv->a.real[i]);
580 #endif
581 v->a.character[i] = dup_char (printf_buf);
582 }
583 }
584
585 delete_vector (ipv);
586 return (ENT (v));
587 }
588
589 ENTITY *
cast_vector_complex_integer(ipv)590 cast_vector_complex_integer (ipv)
591 VECTOR *ipv;
592 {
593 VECTOR *v;
594 int i;
595
596 EASSERT (ipv, vector, complex);
597
598 v = (VECTOR *) form_vector (ipv->ne, integer, ipv->density);
599 if (ipv->eid != NULL)
600 v->eid = copy_entity (ipv->eid);
601 if (ipv->ja != NULL)
602 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
603
604 v->nn = ipv->nn;
605 if (ipv->a.complex != NULL)
606 {
607 if (v->a.integer == NULL)
608 v->a.integer = E_MALLOC (v->nn, integer);
609 for (i = 0; i < v->nn; i++)
610 v->a.integer[i] = (int) round (ipv->a.complex[i].real);
611 }
612
613 delete_entity (ENT (ipv));
614 return (ENT (v));
615 }
616
617 ENTITY *
cast_vector_complex_real(ipv)618 cast_vector_complex_real (ipv)
619 VECTOR *ipv;
620 {
621 VECTOR *v;
622 int i;
623
624 EASSERT (ipv, vector, complex);
625
626 v = (VECTOR *) form_vector (ipv->ne, real, ipv->density);
627 if (ipv->eid != NULL)
628 v->eid = copy_entity (ipv->eid);
629 if (ipv->ja != NULL)
630 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
631
632 v->nn = ipv->nn;
633 if (ipv->a.complex != NULL)
634 {
635 if (v->a.real == NULL)
636 v->a.real = E_MALLOC (v->nn, real);
637 for (i = 0; i < v->nn; i++)
638 v->a.real[i] = ipv->a.complex[i].real;
639 }
640
641 delete_entity (ENT (ipv));
642 return (ENT (v));
643 }
644
645 ENTITY *
cast_vector_complex_character(ipv)646 cast_vector_complex_character (ipv)
647 VECTOR *ipv;
648 {
649 VECTOR *v;
650 int i;
651 int d = DIGITS;
652
653 EASSERT (ipv, vector, complex);
654
655 v = (VECTOR *) form_vector (ipv->ne, character, ipv->density);
656 if (ipv->eid != NULL) v->eid = copy_entity (ipv->eid);
657 if (ipv->ja != NULL)
658 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
659
660 v->nn = ipv->nn;
661 if (ipv->a.complex != NULL)
662 {
663 if (v->a.character == NULL)
664 v->a.character = E_MALLOC (v->nn, character);
665 for (i = 0; i < v->nn; i++)
666 {
667 #if HAVE_SNPRINTF
668 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%#.*g + %#.*g*i",
669 d, ipv->a.complex[i].real,
670 d, ipv->a.complex[i].imag) >= PRINTF_BUF_SIZE)
671 {
672 fail ("Overflow in sprintf buffer.");
673 raise_exception ();
674 }
675 #else
676 sprintf (printf_buf, "%#.*g + %#.*g*i",
677 d, ipv->a.complex[i].real, d, ipm->a.complex[i].imag);
678 #endif
679 v->a.character[i] = dup_char (printf_buf);
680 }
681 }
682
683 delete_entity (ENT (ipv));
684 return ENT (v);
685 }
686
687 ENTITY *
cast_vector_character_integer(ipv)688 cast_vector_character_integer (ipv)
689 VECTOR *ipv;
690 {
691 VECTOR *v;
692 int i;
693
694 EASSERT (ipv, vector, character);
695
696 v = (VECTOR *) form_vector (ipv->ne, integer, ipv->density);
697 if (ipv->eid != NULL)
698 v->eid = copy_entity (ipv->eid);
699 if (ipv->ja != NULL)
700 v->ja = dup_mem (ipv->ja, ipv->nn * sizeof (int));
701
702 v->nn = ipv->nn;
703 if (ipv->a.character != NULL)
704 {
705 if (v->a.integer == NULL)
706 v->a.integer = E_MALLOC (v->nn, integer);
707 for (i = 0; i < v->nn; i++)
708 v->a.integer[i] = *ipv->a.character[i];
709 }
710
711 delete_entity (ENT (ipv));
712 return (ENT (v));
713 }
714
715 ENTITY *
cast_matrix_integer_real(ipm)716 cast_matrix_integer_real (ipm)
717 MATRIX *ipm;
718 {
719 MATRIX *m;
720 int i;
721
722 EASSERT (ipm, matrix, integer);
723
724 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, real, ipm->density);
725 m->symmetry = ipm->symmetry;
726 m->order = ipm->order;
727 if (ipm->rid != NULL)
728 m->rid = copy_entity (ipm->rid);
729 if (ipm->cid != NULL)
730 m->cid = copy_entity (ipm->cid);
731 if (ipm->ia != NULL)
732 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
733 if (ipm->ja != NULL)
734 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
735
736 m->nn = ipm->nn;
737 if (ipm->a.integer != NULL)
738 {
739 if (m->a.real == NULL)
740 m->a.real = E_MALLOC (m->nn, real);
741 for (i = 0; i < m->nn; i++)
742 m->a.real[i] = (REAL) ipm->a.integer[i];
743 }
744 if (ipm->d.integer != NULL)
745 {
746 if (m->d.real == NULL)
747 m->d.real = E_MALLOC (m->nr, real);
748 for (i = 0; i < m->nr; i++)
749 m->d.real[i] = (REAL) ipm->d.integer[i];
750 }
751
752 delete_entity (ENT (ipm));
753 return (ENT (m));
754 }
755
756 ENTITY *
cast_matrix_integer_complex(ipm)757 cast_matrix_integer_complex (ipm)
758 MATRIX *ipm;
759 {
760 MATRIX *m;
761 int i;
762
763 EASSERT (ipm, matrix, integer);
764
765 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, complex, ipm->density);
766 switch (ipm->symmetry)
767 {
768 case symmetric:
769 m->symmetry = hermitian;
770 break;
771 default:
772 m->symmetry = ipm->symmetry;
773 }
774 m->order = ipm->order;
775 if (ipm->rid != NULL)
776 m->rid = copy_entity (ipm->rid);
777 if (ipm->cid != NULL)
778 m->cid = copy_entity (ipm->cid);
779 if (ipm->ia != NULL)
780 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
781 if (ipm->ja != NULL)
782 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
783
784 m->nn = ipm->nn;
785 if (ipm->a.integer != NULL)
786 {
787 if (m->a.complex == NULL)
788 m->a.complex = E_MALLOC (m->nn, complex);
789 for (i = 0; i < m->nn; i++)
790 {
791 m->a.complex[i].real = (REAL) ipm->a.integer[i];
792 m->a.complex[i].imag = 0.0;
793 }
794 }
795 if (ipm->d.integer != NULL)
796 {
797 if (m->d.complex == NULL)
798 m->d.complex = E_MALLOC (m->nr, complex);
799 for (i = 0; i < m->nr; i++)
800 {
801 m->d.complex[i].real = (REAL) ipm->d.integer[i];
802 m->d.complex[i].imag = 0.0;
803 }
804 }
805
806 delete_entity (ENT (ipm));
807 return (ENT (m));
808 }
809
810 ENTITY *
cast_matrix_integer_character(ipm)811 cast_matrix_integer_character (ipm)
812 MATRIX *ipm;
813 {
814 MATRIX *m;
815 int i;
816
817 EASSERT (ipm, matrix, integer);
818
819 ipm = (MATRIX *) dense_matrix (ipm);
820
821 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, character, ipm->density);
822
823 if (ipm->rid != NULL) m->rid = copy_entity (ipm->rid);
824 if (ipm->cid != NULL) m->cid = copy_entity (ipm->cid);
825
826 m->nn = ipm->nn;
827 if (m->nn > 0)
828 {
829 assert (m->a.character);
830 for (i = 0; i < m->nn; i++)
831 {
832 #if HAVE_SNPRINTF
833 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%d", ipm->a.integer[i])
834 >= PRINTF_BUF_SIZE)
835 {
836 fail ("Overflow in sprintf buffer.");
837 raise_exception ();
838 }
839 #else
840 sprintf (printf_buf, "%d", ipm->a.integer[i]);
841 #endif
842 m->a.character[i] = dup_char (printf_buf);
843 }
844 }
845
846 delete_matrix (ipm);
847 return ENT (m);
848 }
849
850 ENTITY *
cast_matrix_real_integer(ipm)851 cast_matrix_real_integer (ipm)
852 MATRIX *ipm;
853 {
854 MATRIX *m;
855 int i;
856
857 EASSERT (ipm, matrix, real);
858
859 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, integer, ipm->density);
860 m->symmetry = ipm->symmetry;
861 m->order = ipm->order;
862 if (ipm->rid != NULL)
863 m->rid = copy_entity (ipm->rid);
864 if (ipm->cid != NULL)
865 m->cid = copy_entity (ipm->cid);
866 if (ipm->ia != NULL)
867 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
868 if (ipm->ja != NULL)
869 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
870
871 m->nn = ipm->nn;
872 if (ipm->a.real != NULL)
873 {
874 if (m->a.integer == NULL)
875 m->a.integer = E_MALLOC (m->nn, integer);
876 for (i = 0; i < m->nn; i++)
877 m->a.integer[i] = (int) round (ipm->a.real[i]);
878 }
879 if (ipm->d.real != NULL)
880 {
881 if (m->d.integer == NULL)
882 m->d.integer = E_MALLOC (m->nr, integer);
883 for (i = 0; i < m->nr; i++)
884 m->d.integer[i] = (int) round (ipm->d.real[i]);
885 }
886
887 delete_entity (ENT (ipm));
888 return (ENT (m));
889 }
890
891 ENTITY *
cast_matrix_real_complex(ipm)892 cast_matrix_real_complex (ipm)
893 MATRIX *ipm;
894 {
895 MATRIX *m;
896 int i;
897
898 EASSERT (ipm, matrix, real);
899
900 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, complex, ipm->density);
901 switch (ipm->symmetry)
902 {
903 case symmetric:
904 m->symmetry = hermitian;
905 break;
906 default:
907 m->symmetry = ipm->symmetry;
908 }
909 m->order = ipm->order;
910 if (ipm->rid != NULL)
911 m->rid = copy_entity (ipm->rid);
912 if (ipm->cid != NULL)
913 m->cid = copy_entity (ipm->cid);
914 if (ipm->ia != NULL)
915 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
916 if (ipm->ja != NULL)
917 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
918
919 m->nn = ipm->nn;
920 if (ipm->a.real != NULL)
921 {
922 if (m->a.complex == NULL)
923 m->a.complex = E_MALLOC (m->nn, complex);
924 for (i = 0; i < m->nn; i++)
925 {
926 m->a.complex[i].real = ipm->a.real[i];
927 m->a.complex[i].imag = 0.0;
928 }
929 }
930 if (ipm->d.real != NULL)
931 {
932 if (m->d.complex == NULL)
933 m->d.complex = E_MALLOC (m->nr, complex);
934 for (i = 0; i < m->nr; i++)
935 {
936 m->d.complex[i].real = ipm->d.real[i];
937 m->d.complex[i].imag = 0.0;
938 }
939 }
940
941 delete_matrix (ipm);
942 return (ENT (m));
943 }
944
945 ENTITY *
cast_matrix_real_character(ipm)946 cast_matrix_real_character (ipm)
947 MATRIX *ipm;
948 {
949 MATRIX *m;
950 int i;
951 int d = DIGITS;
952
953 EASSERT (ipm, matrix, real);
954
955 ipm = (MATRIX *) dense_matrix (ipm);
956
957 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, character, ipm->density);
958
959 if (ipm->rid != NULL) m->rid = copy_entity (ipm->rid);
960 if (ipm->cid != NULL) m->cid = copy_entity (ipm->cid);
961
962 m->nn = ipm->nn;
963 if (m->nn > 0)
964 {
965 assert (m->a.character);
966 for (i = 0; i < m->nn; i++)
967 {
968 #if HAVE_SNPRINTF
969 if (snprintf (printf_buf, PRINTF_BUF_SIZE,
970 "%#.*g", d, ipm->a.real[i])
971 >= PRINTF_BUF_SIZE)
972 {
973 fail ("Overflow in sprintf buffer.");
974 raise_exception ();
975 }
976 #else
977 sprintf (printf_buf, "%#.*g", d, ipm->a.real[i]);
978 #endif
979 m->a.character[i] = dup_char (printf_buf);
980 }
981 }
982
983 delete_matrix (ipm);
984 return ENT (m);
985 }
986
987 ENTITY *
cast_matrix_complex_integer(ipm)988 cast_matrix_complex_integer (ipm)
989 MATRIX *ipm;
990 {
991 MATRIX *m;
992 int i;
993
994 EASSERT (ipm, matrix, complex);
995
996 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, integer, ipm->density);
997 m->symmetry = ipm->symmetry;
998 if (m->symmetry == hermitian)
999 m->symmetry = symmetric;
1000 m->order = ipm->order;
1001 if (ipm->rid != NULL)
1002 m->rid = copy_entity (ipm->rid);
1003 if (ipm->cid != NULL)
1004 m->cid = copy_entity (ipm->cid);
1005 if (ipm->ia != NULL)
1006 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
1007 if (ipm->ja != NULL)
1008 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
1009
1010 m->nn = ipm->nn;
1011 if (ipm->a.complex != NULL)
1012 {
1013 if (m->a.integer == NULL)
1014 m->a.integer = E_MALLOC (m->nn, integer);
1015 for (i = 0; i < m->nn; i++)
1016 m->a.integer[i] = (int) round (ipm->a.complex[i].real);
1017 }
1018 if (ipm->d.complex != NULL)
1019 {
1020 if (m->d.integer == NULL)
1021 m->d.integer = E_MALLOC (m->nr, integer);
1022 for (i = 0; i < m->nr; i++)
1023 m->d.integer[i] = (int) round (ipm->d.complex[i].real);
1024 }
1025
1026 delete_entity (ENT (ipm));
1027 return (ENT (m));
1028 }
1029
1030 ENTITY *
cast_matrix_complex_real(ipm)1031 cast_matrix_complex_real (ipm)
1032 MATRIX *ipm;
1033 {
1034 MATRIX *m;
1035 int i;
1036
1037 EASSERT (ipm, matrix, complex);
1038
1039 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, real, ipm->density);
1040 m->symmetry = ipm->symmetry;
1041 if (m->symmetry == hermitian)
1042 m->symmetry = symmetric;
1043 m->order = ipm->order;
1044 if (ipm->rid != NULL)
1045 m->rid = copy_entity (ipm->rid);
1046 if (ipm->cid != NULL)
1047 m->cid = copy_entity (ipm->cid);
1048 if (ipm->ia != NULL)
1049 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
1050 if (ipm->ja != NULL)
1051 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
1052
1053 m->nn = ipm->nn;
1054 if (ipm->a.complex != NULL)
1055 {
1056 if (m->a.real == NULL)
1057 m->a.real = E_MALLOC (m->nn, real);
1058 for (i = 0; i < m->nn; i++)
1059 m->a.real[i] = ipm->a.complex[i].real;
1060 }
1061 if (ipm->d.complex != NULL)
1062 {
1063 if (m->d.real == NULL)
1064 m->d.real = E_MALLOC (m->nr, real);
1065 for (i = 0; i < m->nr; i++)
1066 m->d.real[i] = ipm->d.complex[i].real;
1067 }
1068
1069 delete_entity (ENT (ipm));
1070 return (ENT (m));
1071 }
1072
1073 ENTITY *
cast_matrix_complex_character(ipm)1074 cast_matrix_complex_character (ipm)
1075 MATRIX *ipm;
1076 {
1077 MATRIX *m;
1078 int i;
1079 int d = DIGITS;
1080
1081 EASSERT (ipm, matrix, complex);
1082
1083 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, character, ipm->density);
1084 m->symmetry = ipm->symmetry == hermitian ? general : ipm->symmetry;
1085 if (ipm->rid != NULL) m->rid = copy_entity (ipm->rid);
1086 if (ipm->cid != NULL) m->cid = copy_entity (ipm->cid);
1087 if (ipm->ia != NULL)
1088 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
1089 if (ipm->ja != NULL)
1090 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
1091
1092 m->nn = ipm->nn;
1093 if (ipm->a.complex != NULL)
1094 {
1095 if (m->a.character == NULL)
1096 m->a.character = E_MALLOC (m->nn, character);
1097 for (i = 0; i < m->nn; i++)
1098 {
1099 #if HAVE_SNPRINTF
1100 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%#.*g + %#.*g*i",
1101 d, ipm->a.complex[i].real,
1102 d, ipm->a.complex[i].imag) >= PRINTF_BUF_SIZE)
1103 {
1104 fail ("Overflow in sprintf buffer.");
1105 raise_exception ();
1106 }
1107 #else
1108 sprintf (printf_buf, "%#.*g + %#.*g*i",
1109 d, ipm->a.complex[i].real, d, ipm->a.complex[i].imag);
1110 #endif
1111 m->a.character[i] = dup_char (printf_buf);
1112 }
1113 }
1114 if (ipm->d.complex != NULL)
1115 {
1116 if (m->d.character == NULL)
1117 m->d.character = E_MALLOC (m->nr, character);
1118 for (i = 0; i < m->nr; i++)
1119 {
1120 #if HAVE_SNPRINTF
1121 if (snprintf (printf_buf, PRINTF_BUF_SIZE, "%#.*g + %#.*g*i",
1122 d, ipm->d.complex[i].real,
1123 d, ipm->d.complex[i].imag) >= PRINTF_BUF_SIZE)
1124 {
1125 fail ("Overflow in sprintf buffer.");
1126 raise_exception ();
1127 }
1128 #else
1129 sprintf (printf_buf, "%#.*g + %#.*g*i",
1130 d, ipm->d.complex[i].real, d, ipm->d.complex[i].imag);
1131 #endif
1132 m->d.character[i] = dup_char (printf_buf);
1133 }
1134 }
1135
1136 delete_entity (ENT (ipm));
1137 return ENT (m);
1138 }
1139
1140 ENTITY *
cast_matrix_character_integer(ipm)1141 cast_matrix_character_integer (ipm)
1142 MATRIX *ipm;
1143 {
1144 MATRIX *m;
1145 int i;
1146
1147 EASSERT (ipm, matrix, character);
1148
1149 m = (MATRIX *) form_matrix (ipm->nr, ipm->nc, integer, ipm->density);
1150 m->symmetry = ipm->symmetry;
1151 m->order = ipm->order;
1152 if (ipm->rid != NULL)
1153 m->rid = copy_entity (ipm->rid);
1154 if (ipm->cid != NULL)
1155 m->cid = copy_entity (ipm->cid);
1156 if (ipm->ia != NULL)
1157 m->ia = dup_mem (ipm->ia, (ipm->nr + 1) * sizeof (int));
1158 if (ipm->ja != NULL)
1159 m->ja = dup_mem (ipm->ja, ipm->nn * sizeof (int));
1160
1161 m->nn = ipm->nn;
1162 if (ipm->a.character != NULL)
1163 {
1164 if (m->a.integer == NULL)
1165 m->a.integer = E_MALLOC (m->nn, integer);
1166 for (i = 0; i < m->nn; i++)
1167 m->a.integer[i] = *ipm->a.character[i];
1168 }
1169 if (ipm->d.character != NULL)
1170 {
1171 if (m->d.integer == NULL)
1172 m->d.integer = E_MALLOC (m->nr, integer);
1173 for (i = 0; i < m->nr; i++)
1174 m->d.integer[i] = *ipm->d.character[i];
1175 }
1176
1177 delete_entity (ENT (ipm));
1178 return (ENT (m));
1179 }
1180
1181 #ifdef STUPID_CPP
1182
1183 void
auto_cast(l,l_type,r,r_type)1184 auto_cast (l, l_type, r, r_type)
1185 ENTITY **l;
1186 TYPE l_type;
1187 ENTITY **r;
1188 TYPE r_type;
1189 {
1190 switch (TWO_TYPE (l_type, r_type))
1191 {
1192 case integer_integer:
1193 case real_real:
1194 case complex_complex:
1195 case character_character:
1196 break;
1197 case integer_real:
1198 *l = cast_entity (EAT (*l), real);
1199 break;
1200 case integer_complex:
1201 case real_complex:
1202 *l = cast_entity (EAT (*l), complex);
1203 break;
1204 case integer_character:
1205 case real_character:
1206 case complex_character:
1207 *l = cast_entity (EAT (*l), character);
1208 break;
1209 case real_integer:
1210 *r = cast_entity (EAT (*r), real);
1211 break;
1212 case complex_integer:
1213 case complex_real:
1214 *r = cast_entity (EAT (*r), complex);
1215 break;
1216 case character_integer:
1217 case character_real:
1218 case character_complex:
1219 *r = cast_entity (EAT (*r), character);
1220 break;
1221 default:
1222 wipeout ("Bad type.");
1223 }
1224 }
1225
1226 void
auto_cast_scalar(l,r)1227 auto_cast_scalar (l, r)
1228 SCALAR **l;
1229 SCALAR **r;
1230 {
1231 if ((*l)->type != (*r)->type)
1232 {
1233 switch (TWO_TYPE ((*l)->type, (*r)->type))
1234 {
1235 case integer_real:
1236 (*l) = (SCALAR *) cast_scalar_integer_real ((SCALAR *) EAT (*l));
1237 break;
1238 case integer_complex:
1239 (*l) = (SCALAR *) cast_scalar_integer_complex ((SCALAR *) EAT (*l));
1240 break;
1241 case real_complex:
1242 (*l) = (SCALAR *) cast_scalar_real_complex ((SCALAR *) EAT (*l));
1243 break;
1244 case integer_character:
1245 (*l) = (SCALAR *) cast_scalar_integer_character ((SCALAR *) EAT (*l));
1246 break;
1247 case real_character:
1248 (*l) = (SCALAR *) cast_scalar_real_character ((SCALAR *) EAT (*l));
1249 break;
1250 case complex_character:
1251 (*l) = (SCALAR *) cast_scalar_complex_character ((SCALAR *) EAT (*l));
1252 break;
1253 case real_integer:
1254 (*r) = (SCALAR *) cast_scalar_integer_real ((SCALAR *) EAT (*r));
1255 break;
1256 case complex_integer:
1257 (*r) = (SCALAR *) cast_scalar_integer_complex ((SCALAR *) EAT (*r));
1258 break;
1259 case complex_real:
1260 (*r) = (SCALAR *) cast_scalar_real_complex ((SCALAR *) EAT (*r));
1261 break;
1262 case character_integer:
1263 (*r) = (SCALAR *) cast_scalar_integer_character ((SCALAR *) EAT (*r));
1264 break;
1265 case character_real:
1266 (*r) = (SCALAR *) cast_scalar_real_character ((SCALAR *) EAT (*r));
1267 break;
1268 case character_complex:
1269 (*r) = (SCALAR *) cast_scalar_complex_character ((SCALAR *) EAT (*r));
1270 break;
1271 default:
1272 wipeout ("Bad type.");
1273 }
1274 }
1275 }
1276
1277 void
auto_cast_vector(l,r)1278 auto_cast_vector (l, r)
1279 VECTOR **l;
1280 VECTOR **r;
1281 {
1282 if ((*l)->type != (*r)->type)
1283 {
1284 switch (TWO_TYPE ((*l)->type, (*r)->type))
1285 {
1286 case integer_real:
1287 (*l) = (VECTOR *) cast_vector_integer_real ((VECTOR *) EAT (*l));
1288 break;
1289 case integer_complex:
1290 (*l) = (VECTOR *) cast_vector_integer_complex ((VECTOR *) EAT (*l));
1291 break;
1292 case real_complex:
1293 (*l) = (VECTOR *) cast_vector_real_complex ((VECTOR *) EAT (*l));
1294 break;
1295 case integer_character:
1296 (*l) = (VECTOR *) cast_vector_integer_character ((VECTOR *) EAT (*l));
1297 break;
1298 case real_character:
1299 (*l) = (VECTOR *) cast_vector_real_character ((VECTOR *) EAT (*l));
1300 break;
1301 case complex_character:
1302 (*l) = (VECTOR *) cast_vector_complex_character ((VECTOR *) EAT (*l));
1303 break;
1304 case real_integer:
1305 (*r) = (VECTOR *) cast_vector_integer_real ((VECTOR *) EAT (*r));
1306 break;
1307 case complex_integer:
1308 (*r) = (VECTOR *) cast_vector_integer_complex ((VECTOR *) EAT (*r));
1309 break;
1310 case complex_real:
1311 (*r) = (VECTOR *) cast_vector_real_complex ((VECTOR *) EAT (*r));
1312 break;
1313 case character_integer:
1314 (*r) = (VECTOR *) cast_vector_integer_character ((VECTOR *) EAT (*r));
1315 break;
1316 case character_real:
1317 (*r) = (VECTOR *) cast_vector_real_character ((VECTOR *) EAT (*r));
1318 break;
1319 case character_complex:
1320 (*r) = (VECTOR *) cast_vector_complex_character ((VECTOR *) EAT (*r));
1321 break;
1322 default:
1323 wipeout ("Bad type.");
1324 }
1325 }
1326 }
1327
1328 void
auto_cast_matrix(l,r)1329 auto_cast_matrix (l, r)
1330 MATRIX **l;
1331 MATRIX **r;
1332 {
1333 if ((*l)->type != (*r)->type)
1334 {
1335 switch (TWO_TYPE ((*l)->type, (*r)->type))
1336 {
1337 case integer_real:
1338 (*l) = (MATRIX *) cast_matrix_integer_real ((MATRIX *) EAT (*l));
1339 break;
1340 case integer_complex:
1341 (*l) = (MATRIX *) cast_matrix_integer_complex ((MATRIX *) EAT (*l));
1342 break;
1343 case real_complex:
1344 (*l) = (MATRIX *) cast_matrix_real_complex ((MATRIX *) EAT (*l));
1345 break;
1346 case integer_character:
1347 (*l) = (MATRIX *) cast_matrix_integer_character ((MATRIX *) EAT (*l));
1348 break;
1349 case real_character:
1350 (*l) = (MATRIX *) cast_matrix_real_character ((MATRIX *) EAT (*l));
1351 break;
1352 case complex_character:
1353 (*l) = (MATRIX *) cast_matrix_complex_character ((MATRIX *) EAT (*l));
1354 break;
1355 case real_integer:
1356 (*r) = (MATRIX *) cast_matrix_integer_real ((MATRIX *) EAT (*r));
1357 break;
1358 case complex_integer:
1359 (*r) = (MATRIX *) cast_matrix_integer_complex ((MATRIX *) EAT (*r));
1360 break;
1361 case complex_real:
1362 (*r) = (MATRIX *) cast_matrix_real_complex ((MATRIX *) EAT (*r));
1363 break;
1364 case character_integer:
1365 (*r) = (MATRIX *) cast_matrix_integer_character ((MATRIX *) EAT (*r));
1366 break;
1367 case character_real:
1368 (*r) = (MATRIX *) cast_matrix_real_character ((MATRIX *) EAT (*r));
1369 break;
1370 case character_complex:
1371 (*r) = (MATRIX *) cast_matrix_complex_character ((MATRIX *) EAT (*r));
1372 break;
1373 default:
1374 wipeout ("Bad type.");
1375 }
1376 }
1377 }
1378
1379 void
auto_cast_vector_scalar(l,r)1380 auto_cast_vector_scalar (l, r)
1381 VECTOR **l;
1382 SCALAR **r;
1383 {
1384 if ((*l)->type != (*r)->type)
1385 {
1386 switch (TWO_TYPE ((*l)->type, (*r)->type))
1387 {
1388 case integer_real:
1389 (*l) = (VECTOR *) cast_vector_integer_real ((VECTOR *) EAT (*l));
1390 break;
1391 case integer_complex:
1392 (*l) = (VECTOR *) cast_vector_integer_complex ((VECTOR *) EAT (*l));
1393 break;
1394 case real_complex:
1395 (*l) = (VECTOR *) cast_vector_real_complex ((VECTOR *) EAT (*l));
1396 break;
1397 case integer_character:
1398 (*l) = (VECTOR *) cast_vector_integer_character ((VECTOR *) EAT (*l));
1399 break;
1400 case real_character:
1401 (*l) = (VECTOR *) cast_vector_real_character ((VECTOR *) EAT (*l));
1402 break;
1403 case complex_character:
1404 (*l) = (VECTOR *) cast_vector_complex_character ((VECTOR *) EAT (*l));
1405 break;
1406 case real_integer:
1407 (*r) = (SCALAR *) cast_scalar_integer_real ((SCALAR *) EAT (*r));
1408 break;
1409 case complex_integer:
1410 (*r) = (SCALAR *) cast_scalar_integer_complex ((SCALAR *) EAT (*r));
1411 break;
1412 case complex_real:
1413 (*r) = (SCALAR *) cast_scalar_real_complex ((SCALAR *) EAT (*r));
1414 break;
1415 case character_integer:
1416 (*r) = (SCALAR *) cast_scalar_integer_character ((SCALAR *) EAT (*r));
1417 break;
1418 case character_real:
1419 (*r) = (SCALAR *) cast_scalar_real_character ((SCALAR *) EAT (*r));
1420 break;
1421 case character_complex:
1422 (*r) = (SCALAR *) cast_scalar_complex_character ((SCALAR *) EAT (*r));
1423 break;
1424 default:
1425 wipeout ("Bad type.");
1426 }
1427 }
1428 }
1429
1430 void
auto_cast_matrix_scalar(l,r)1431 auto_cast_matrix_scalar (l, r)
1432 MATRIX **l;
1433 SCALAR **r;
1434 {
1435 if ((*l)->type != (*r)->type)
1436 {
1437 switch (TWO_TYPE ((*l)->type, (*r)->type))
1438 {
1439 case integer_real:
1440 (*l) = (MATRIX *) cast_matrix_integer_real ((MATRIX *) EAT (*l));
1441 break;
1442 case integer_complex:
1443 (*l) = (MATRIX *) cast_matrix_integer_complex ((MATRIX *) EAT (*l));
1444 break;
1445 case real_complex:
1446 (*l) = (MATRIX *) cast_matrix_real_complex ((MATRIX *) EAT (*l));
1447 break;
1448 case integer_character:
1449 (*l) = (MATRIX *) cast_matrix_integer_character ((MATRIX *) EAT (*l));
1450 break;
1451 case real_character:
1452 (*l) = (MATRIX *) cast_matrix_real_character ((MATRIX *) EAT (*l));
1453 break;
1454 case complex_character:
1455 (*l) = (MATRIX *) cast_matrix_complex_character ((MATRIX *) EAT (*l));
1456 break;
1457 case real_integer:
1458 (*r) = (SCALAR *) cast_scalar_integer_real ((SCALAR *) EAT (*r));
1459 break;
1460 case complex_integer:
1461 (*r) = (SCALAR *) cast_scalar_integer_complex ((SCALAR *) EAT (*r));
1462 break;
1463 case complex_real:
1464 (*r) = (SCALAR *) cast_scalar_real_complex ((SCALAR *) EAT (*r));
1465 break;
1466 case character_integer:
1467 (*r) = (SCALAR *) cast_scalar_integer_character ((SCALAR *) EAT (*r));
1468 break;
1469 case character_real:
1470 (*r) = (SCALAR *) cast_scalar_real_character ((SCALAR *) EAT (*r));
1471 break;
1472 case character_complex:
1473 (*r) = (SCALAR *) cast_scalar_complex_character ((SCALAR *) EAT (*r));
1474 break;
1475 default:
1476 wipeout ("Bad type.");
1477 }
1478 }
1479 }
1480
1481 void
auto_cast_matrix_vector(l,r)1482 auto_cast_matrix_vector (l, r)
1483 MATRIX **l;
1484 VECTOR **r;
1485 {
1486 if ((*l)->type != (*r)->type)
1487 {
1488 switch (TWO_TYPE ((*l)->type, (*r)->type))
1489 {
1490 case integer_real:
1491 (*l) = (MATRIX *) cast_matrix_integer_real ((MATRIX *) EAT (*l));
1492 break;
1493 case integer_complex:
1494 (*l) = (MATRIX *) cast_matrix_integer_complex ((MATRIX *) EAT (*l));
1495 break;
1496 case real_complex:
1497 (*l) = (MATRIX *) cast_matrix_real_complex ((MATRIX *) EAT (*l));
1498 break;
1499 case integer_character:
1500 (*l) = (MATRIX *) cast_matrix_integer_character ((MATRIX *) EAT (*l));
1501 break;
1502 case real_character:
1503 (*l) = (MATRIX *) cast_matrix_real_character ((MATRIX *) EAT (*l));
1504 break;
1505 case complex_character:
1506 (*l) = (MATRIX *) cast_matrix_complex_character ((MATRIX *) EAT (*l));
1507 break;
1508 case real_integer:
1509 (*r) = (VECTOR *) cast_vector_integer_real ((VECTOR *) EAT (*r));
1510 break;
1511 case complex_integer:
1512 (*r) = (VECTOR *) cast_vector_integer_complex ((VECTOR *) EAT (*r));
1513 break;
1514 case complex_real:
1515 (*r) = (VECTOR *) cast_vector_real_complex ((VECTOR *) EAT (*r));
1516 break;
1517 case character_integer:
1518 (*r) = (VECTOR *) cast_vector_integer_character ((VECTOR *) EAT (*r));
1519 break;
1520 case character_real:
1521 (*r) = (VECTOR *) cast_vector_real_character ((VECTOR *) EAT (*r));
1522 break;
1523 case character_complex:
1524 (*r) = (VECTOR *) cast_vector_complex_character ((VECTOR *) EAT (*r));
1525 break;
1526 default:
1527 wipeout ("Bad type.");
1528 }
1529 }
1530 }
1531
1532 #endif /* STUPID_CPP */
1533