1 // Copyright (c) 1999-2014 OPEN CASCADE SAS
2 //
3 // This file is part of Open CASCADE Technology software library.
4 //
5 // This library is free software; you can redistribute it and/or modify it under
6 // the terms of the GNU Lesser General Public License version 2.1 as published
7 // by the Free Software Foundation, with special exception defined in the file
8 // OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
9 // distribution for complete text of the license and disclaimer of any warranty.
10 //
11 // Alternatively, this file may be used under the terms of Open CASCADE
12 // commercial license or contractual agreement.
13
14 // AdvApp2Var_SysBase.cxx
15 #include <assert.h>
16 #include <cmath>
17 #include <stdlib.h>
18 #include <string.h>
19 #include <AdvApp2Var_Data_f2c.hxx>
20 #include <AdvApp2Var_SysBase.hxx>
21 #include <AdvApp2Var_Data.hxx>
22 #include <Standard.hxx>
23
24
25 static
26 int __i__len();
27
28 static
29 int __s__cmp();
30
31 static
32 int macrbrk_();
33
34 static
35 int macrclw_(intptr_t *iadfld,
36 intptr_t *iadflf,
37 integer *nalloc);
38 static
39 int macrerr_(intptr_t *iad,
40 intptr_t *nalloc);
41 static
42 int macrgfl_(intptr_t *iadfld,
43 intptr_t *iadflf,
44 integer *iphase,
45 integer *iznuti);
46 static
47 int macrmsg_(const char *crout,
48 integer *num,
49 integer *it,
50 doublereal *xt,
51 const char *ct,
52 ftnlen crout_len,
53 ftnlen ct_len);
54
55 static
56 int macrstw_(intptr_t *iadfld,
57 intptr_t *iadflf,
58 integer *nalloc);
59
60 static
61 int madbtbk_(integer *indice);
62
63 static
64 int magtlog_(const char *cnmlog,
65 const char *chaine,
66 integer *long__,
67 integer *iercod,
68 ftnlen cnmlog_len,
69 ftnlen chaine_len);
70
71
72 static
73 int mamdlng_(char *cmdlng,
74 ftnlen cmdlng_len);
75
76 static
77 int maostrb_();
78
79 static
80 int maostrd_();
81
82 static
83 int maoverf_(integer *nbentr,
84 doublereal *dtable);
85
86 static
87 int matrlog_(const char *cnmlog,
88 const char *chaine,
89 integer *length,
90 integer *iercod,
91 ftnlen cnmlog_len,
92 ftnlen chaine_len);
93
94 static
95 int matrsym_(const char *cnmsym,
96 const char *chaine,
97 integer *length,
98 integer *iercod,
99 ftnlen cnmsym_len,
100 ftnlen chaine_len);
101
102 static
103 int mcrcomm_(integer *kop,
104 integer *noct,
105 intptr_t *iadr,
106 integer *ier);
107
108 static
109 int mcrfree_(integer *ibyte,
110 intptr_t iadr,
111 integer *ier);
112
113 static
114 int mcrgetv_(integer *sz,
115 intptr_t *iad,
116 integer *ier);
117
118 static struct {
119 integer lec, imp, keyb, mae, jscrn, itblt, ibb;
120 } mblank__;
121
122 #define mcrfill_ABS(a) (((a)<0)?(-(a)):(a))
123
124
125 //=======================================================================
126 //function : AdvApp2Var_SysBase
127 //purpose :
128 //=======================================================================
AdvApp2Var_SysBase()129 AdvApp2Var_SysBase::AdvApp2Var_SysBase()
130 {
131 mainial_();
132 memset (&mcrstac_, 0, sizeof (mcrstac_));
133 }
134
135 //=======================================================================
136 //function : ~AdvApp2Var_SysBase
137 //purpose :
138 //=======================================================================
~AdvApp2Var_SysBase()139 AdvApp2Var_SysBase::~AdvApp2Var_SysBase()
140 {
141 assert (mcrgene_.ncore == 0); //otherwise memory leaking
142 }
143
144 //=======================================================================
145 //function : macinit_
146 //purpose :
147 //=======================================================================
macinit_(integer * imode,integer * ival)148 int AdvApp2Var_SysBase::macinit_(integer *imode,
149 integer *ival)
150
151 {
152
153 /* ************************************************************************/
154 /* FUNCTION : */
155 /* ---------- */
156 /* INITIALIZATION OF READING WRITING UNITS AND 'IBB' */
157
158 /* KEYWORDS : */
159 /* ----------- */
160 /* MANAGEMENT, CONFIGURATION, UNITS, INITIALIZATION */
161
162 /* INPUT ARGUMENTS : */
163 /* -------------------- */
164 /* IMODE : MODE of INITIALIZATION :
165 0= DEFAULT, IMP IS 6, IBB 0 and LEC 5 */
166 /* 1= FORCE VALUE OF IMP */
167 /* 2= FORCE VALUE OF IBB */
168 /* 3= FORCE VALUE OF LEC */
169
170 /* ARGUMENT USED ONLY WHEN IMODE IS 1 OR 2 : */
171 /* IVAL : VALUE OF IMP WHEN IMODE IS 1 */
172 /* VALUE OF IBB WHEN IMODE IS 2 */
173 /* VALUE OF LEC WHEN IMODE IS 3 */
174 /* THERE IS NO CONTROL OF VALIDITY OF VALUE OF IVAL . */
175
176 /* OUTPUT ARGUMENTS : */
177 /* -------------------- */
178 /* NONE */
179
180 /* COMMONS USED : */
181 /* -------------- */
182 /* REFERENCES CALLED : */
183 /* ------------------- */
184 /* DESCRIPTION/NOTES/LIMITATIONS : */
185 /* ------------------------------- */
186
187 /* THIS IS ONLY INITIALIZATION OF THE COMMON BLANK FOR ALL */
188 /* MODULES THAT A PRIORI DO NOT NEED TO KNOW THE COMMONS OF T . */
189 /* WHEN A MODIFICATION OF IBB IS REQUIRED (IMODE=2) AN INFO MESSAGE */
190 /* IS SUBMITTED ON IMP, WITH THE NEW VALUE OF IBB. */
191
192 /* IBB : MODE DEBUG OF STRIM T : RULES OF USE : */
193 /* 0 RESTRAINED VERSION */
194 /* >0 THE GREATER IS IBB THE MORE COMMENTS THE VERSION HAS. */
195 /* FOR EXAMPLE FOR IBB=1 THE ROUTINES CALLED */
196 /* INFORM ON IMP ('INPUT IN TOTO', */
197 /* AND 'OUTPUT FROM TOTO'), AND THE ROUTINES THAT RETURN */
198 /* NON NULL ERROR CODE INFORM IT AS WELL. */
199 /* (BUT IT IS NOT TRUE FOR ALL ROUTINES OF T) */
200 /* > */
201 /* ***********************************************************************
202 */
203
204 if (*imode == 0) {
205 mblank__.imp = 6;
206 mblank__.ibb = 0;
207 mblank__.lec = 5;
208 } else if (*imode == 1) {
209 mblank__.imp = *ival;
210 } else if (*imode == 2) {
211 mblank__.ibb = *ival;
212 } else if (*imode == 3) {
213 mblank__.lec = *ival;
214 }
215
216 /* ----------------------------------------------------------------------*
217 */
218
219 return 0;
220 } /* macinit__ */
221
222 //=======================================================================
223 //function : macrai4_
224 //purpose :
225 //=======================================================================
macrai4_(integer * nbelem,integer * maxelm,integer * itablo,intptr_t * iofset,integer * iercod)226 int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
227 integer *maxelm,
228 integer *itablo,
229 intptr_t *iofset,
230 integer *iercod)
231
232 {
233
234 /* ***********************************************************************
235 */
236
237 /* FUNCTION : */
238 /* ---------- */
239 /* Require dynamic allocation of type INTEGER */
240
241 /* KEYWORDS : */
242 /* ---------- */
243 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
244
245 /* INPUT ARGUMENTS : */
246 /* ----------------- */
247 /* NBELEM : Number of required units */
248 /* MAXELM : Max number of units available in ITABLO */
249 /* ITABLO : Reference Address of the rented zone */
250
251 /* OUTPUT ARGUMENTS : */
252 /* ------------------- */
253 /* IOFSET : Offset */
254 /* IERCOD : Error code */
255 /* = 0 : OK */
256 /* = 1 : Max nb of allocations attained */
257 /* = 2 : Incorrect arguments */
258 /* = 3 : Refused dynamic allocation */
259
260 /* COMMONS USED : */
261 /* ------------------ */
262
263 /* REFERENCES CALLED : */
264 /* --------------------- */
265 /* MCRRQST */
266
267 /* DESCRIPTION/NOTES/LIMITATIONS : */
268 /* ----------------------------------- */
269 /* (Cf description in the heading of MCRRQST) */
270
271 /* Table ITABLO should be dimensioned to MAXELM by the caller. */
272 /* If the request is lower or equal to MAXELM, IOFSET becomes = 0. */
273 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
274 /* > */
275 /* ***********************************************************************
276 */
277
278 integer iunit;
279
280
281 iunit = sizeof(integer);
282 /* Function Body */
283 if (*nbelem > *maxelm) {
284 /*AdvApp2Var_SysBase::*/mcrrqst_(&iunit, nbelem, itablo, iofset, iercod);
285 } else {
286 *iercod = 0;
287 *iofset = 0;
288 }
289 return 0 ;
290 } /* macrai4_ */
291
292 //=======================================================================
293 //function : AdvApp2Var_SysBase::macrar8_
294 //purpose :
295 //=======================================================================
macrar8_(integer * nbelem,integer * maxelm,doublereal * xtablo,intptr_t * iofset,integer * iercod)296 int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
297 integer *maxelm,
298 doublereal *xtablo,
299 intptr_t *iofset,
300 integer *iercod)
301
302 {
303 integer c__8 = 8;
304
305 /* ***********************************************************************
306 */
307
308 /* FUNCTION : */
309 /* ---------- */
310 /* Demand of dynamic allocation of type DOUBLE PRECISION */
311
312 /* KEYWORDS : */
313 /* ----------- */
314 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
315
316 /* INPUT ARGUMENTS : */
317 /* ------------------ */
318 /* NBELEM : Nb of units required */
319 /* MAXELM : Max Nb of units available in XTABLO */
320 /* XTABLO : Reference address of the rented zone */
321
322 /* OUTPUT ARGUMENTS : */
323 /* ------------------ */
324 /* IOFSET : Offset */
325 /* IERCOD : Error code */
326 /* = 0 : OK */
327 /* = 1 : Max Nb of allocations reached */
328 /* = 2 : Arguments incorrect */
329 /* = 3 : Refuse of dynamic allocation */
330
331 /* COMMONS USED : */
332 /* ------------------ */
333
334 /* REFERENCES CALLED : */
335 /* --------------------- */
336 /* MCRRQST */
337
338 /* DESCRIPTION/NOTES/LIMITATIONS : */
339 /* ----------------------------------- */
340 /* (Cf description in the heading of MCRRQST) */
341
342 /* Table XTABLO should be dimensioned to MAXELM by the caller. */
343 /* If the request is less or equal to MAXELM, IOFSET becomes = 0. */
344 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
345
346 /* > */
347 /* ***********************************************************************
348 */
349
350
351 /* Function Body */
352 if (*nbelem > *maxelm) {
353 /*AdvApp2Var_SysBase::*/mcrrqst_(&c__8, nbelem, xtablo, iofset, iercod);
354 } else {
355 *iercod = 0;
356 *iofset = 0;
357 }
358 return 0 ;
359 } /* macrar8_ */
360
361 //=======================================================================
362 //function : macrbrk_
363 //purpose :
364 //=======================================================================
macrbrk_()365 int macrbrk_()
366 {
367 return 0 ;
368 } /* macrbrk_ */
369
370 //=======================================================================
371 //function : macrchk_
372 //purpose :
373 //=======================================================================
macrchk_()374 int AdvApp2Var_SysBase::macrchk_()
375 {
376 /* System generated locals */
377 integer i__1;
378
379 /* Local variables */
380 integer i__, j;
381
382 /* ***********************************************************************
383 */
384
385 /* FUNCTION : */
386 /* ---------- */
387 /* CONTROL OF EXCESSES OF ALLOCATED MEMORY ZONE */
388
389 /* KEYWORDS : */
390 /* ----------- */
391 /* SYSTEM, ALLOCATION, MEMORY, CONTROL, EXCESS */
392
393 /* INPUT ARGUMENTS : */
394 /* ----------------- */
395 /* NONE */
396
397 /* OUTPUT ARGUMENTS : */
398 /* ------------------- */
399 /* NONE */
400
401 /* COMMONS USED : */
402 /* ------------------ */
403 /* MCRGENE */
404
405 /* REFERENCES CALLED : */
406 /* --------------------- */
407 /* MACRERR, MAOSTRD */
408
409 /* DESCRIPTION/NOTES/LIMITATIONS : */
410 /* ----------------------------------- */
411
412 /* > */
413 /* ***********************************************************************
414 */
415
416 /* ***********************************************************************
417 */
418
419 /* FONCTION : */
420 /* ---------- */
421 /* TABLE OF MANAGEMENT OF DYNAMIC MEMOTY ALLOCATIONS */
422
423 /* KEYWORDS : */
424 /* ----------- */
425 /* SYSTEM, MEMORY, ALLOCATION */
426
427 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
428 /* ----------------------------------- */
429
430
431 /* > */
432 /* ***********************************************************************
433 */
434
435 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
436 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
437 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
438 /* 2 : UNIT OF ALLOCATION */
439 /* 3 : NB OF ALLOCATED UNITS */
440 /* 4 : REFERENCE ADDRESS OF THE TABLE */
441 /* 5 : IOFSET */
442 /* 6 : STATIC ALLOCATION NUMBER */
443 /* 7 : Required allocation size */
444 /* 8 : address of the beginning of allocation */
445 /* 9 : Size of the USER ZONE */
446 /* 10 : ADDRESS of the START FLAG */
447 /* 11 : ADDRESS of the END FLAG */
448 /* 12 : Rank of creation of the allocation */
449
450 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
451 /* NCORE : NB OF CURRENT ALLOCS */
452 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
453 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
454
455
456
457 /* ----------------------------------------------------------------------*
458 */
459
460
461 /* ----------------------------------------------------------------------*
462 */
463
464 /* CONTROL OF FLAGS IN THE TABLE */
465 i__1 = mcrgene_.ncore;
466 for (i__ = 0; i__ < i__1; ++i__) {
467
468 //p to access startaddr and endaddr
469 intptr_t* p = &mcrgene_.icore[i__].startaddr;
470 for (j = 0; j <= 1; ++j) {
471 intptr_t* pp = p + j;
472 if (*pp != -1) {
473
474 double* t = reinterpret_cast<double*>(*pp);
475 if (*t != -134744073.)
476 {
477 /* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS
478 E:',ICORE(J,I) */
479 /* AND OF RANK ICORE(12,I) */
480 macrerr_(pp, p + 2);
481
482 /* BACK-PARCING IN PHASE OF PRODUCTION */
483 maostrb_();
484
485 /* REMOVAL OF THE ADDRESS OF FLAG TO AVOID REMAKING ITS CONTROL */
486 *pp = -1;
487
488 }
489
490 }
491
492 /* L100: */
493 }
494
495 /* L1000: */
496 }
497 return 0 ;
498 } /* macrchk_ */
499
500 //=======================================================================
501 //function : macrclw_
502 //purpose :
503 //=======================================================================
macrclw_(intptr_t *,intptr_t *,integer *)504 int macrclw_(intptr_t *,//iadfld,
505 intptr_t *,//iadflf,
506 integer *)//nalloc)
507
508 {
509 return 0 ;
510 } /* macrclw_ */
511
512 //=======================================================================
513 //function : AdvApp2Var_SysBase::macrdi4_
514 //purpose :
515 //=======================================================================
macrdi4_(integer * nbelem,integer *,integer * itablo,intptr_t * iofset,integer * iercod)516 int AdvApp2Var_SysBase::macrdi4_(integer *nbelem,
517 integer *,//maxelm,
518 integer *itablo,
519 intptr_t *iofset, /* Offset long (pmn) */
520 integer *iercod)
521
522 {
523
524 /* ***********************************************************************
525 */
526
527 /* FuNCTION : */
528 /* ---------- */
529 /* Destruction of dynamic allocation of type INTEGER */
530
531 /* KEYWORDS : */
532 /* ----------- */
533 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
534
535 /* INPUT ARGUMENTS : */
536 /* ------------------ */
537 /* NBELEM : Nb of units required */
538 /* MAXELM : Max Nb of units available in ITABLO */
539 /* ITABLO : Reference Address of the allocated zone */
540 /* IOFSET : Offset */
541
542 /* OUTPUT ARGUMENTS : */
543 /* --------------------- */
544 /* IERCOD : Error Code */
545 /* = 0 : OK */
546 /* = 1 : Pb of de-allocation of a zone allocated in table */
547 /* = 2 : The system refuses the demand of de-allocation */
548
549 /* COMMONS USED : */
550 /* ------------------ */
551
552 /* REFERENCES CALLED : */
553 /* --------------------- */
554 /* MCRDELT */
555
556 /* DESCRIPTION/NOTES/LIMITATIONS : */
557 /* ----------------------------------- */
558 /* (Cf description in the heading of MCRDELT) */
559 /* > */
560 /* ***********************************************************************
561 */
562 integer iunit;
563
564 iunit = sizeof(integer);
565 /* Function Body */
566 if (*iofset != 0) {
567 AdvApp2Var_SysBase::mcrdelt_(&iunit,
568 nbelem,
569 itablo,
570 iofset,
571 iercod);
572 } else {
573 *iercod = 0;
574 }
575 return 0 ;
576 } /* macrdi4_ */
577
578 //=======================================================================
579 //function : AdvApp2Var_SysBase::macrdr8_
580 //purpose :
581 //=======================================================================
macrdr8_(integer * nbelem,integer *,doublereal * xtablo,intptr_t * iofset,integer * iercod)582 int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
583 integer *,//maxelm,
584 doublereal *xtablo,
585 intptr_t *iofset,
586 integer *iercod)
587
588 {
589 integer c__8 = 8;
590
591 /* ***********************************************************************
592 */
593
594 /* FUNCTION : */
595 /* ---------- */
596 /* Destruction of dynamic allocation of type DOUBLE PRECISION
597 */
598
599 /* KEYWORDS : */
600 /* ----------- */
601 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
602
603 /* INPUT ARGUMENTS : */
604 /* -------------------- */
605 /* NBELEM : Nb of units required */
606 /* MAXELM : Max nb of units available in XTABLO */
607 /* XTABLO : Reference Address of the allocated zone */
608 /* IOFSET : Offset */
609
610 /* OUTPUT ARGUMENTS : */
611 /* ------------------- */
612 /* IERCOD : Error Code */
613 /* = 0 : OK */
614 /* = 1 : Pb of de-allocation of a zone allocated on table */
615 /* = 2 : The system refuses the demand of de-allocation */
616
617 /* COMMONS USED : */
618 /* -------------- */
619
620 /* REFERENCES CALLEDS : */
621 /* -------------------- */
622 /* MCRDELT */
623
624 /* DESCRIPTION/NOTES/LIMITATIONS : */
625 /* ----------------------------------- */
626 /* (Cf description in the heading of MCRDELT) */
627
628 /* > */
629 /* ***********************************************************************
630 */
631
632 /* Function Body */
633 if (*iofset != 0) {
634 AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, xtablo, iofset, iercod);
635 } else {
636 *iercod = 0;
637 }
638 return 0 ;
639 } /* macrdr8_ */
640
641 //=======================================================================
642 //function : macrerr_
643 //purpose :
644 //=======================================================================
macrerr_(intptr_t *,intptr_t *)645 int macrerr_(intptr_t *,//iad,
646 intptr_t *)//nalloc)
647
648 {
649 //integer c__1 = 1;
650 /* Builtin functions */
651 //integer /*do__fio(),*/;
652
653 /* Fortran I/O blocks */
654 //cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
655
656 /* ***********************************************************************
657 */
658
659 /* FUNCTION : */
660 /* ---------- */
661 /* WRITING OF ADDRESS REMOVED IN ALLOCS . */
662
663 /* KEYWORDS : */
664 /* ----------- */
665 /* ALLOC CONTROL */
666
667 /* INPUT ARGUMENTS : */
668 /* ------------------ */
669 /* IAD : ADDRESS TO INFORM OF REMOVAL */
670 /* NALLOC : NUMBER OF ALLOCATION */
671
672 /* OUTPUT ARGUMENTS : */
673 /* --------------------- */
674 /* NONE */
675
676 /* COMMONS USED : */
677 /* -------------- */
678
679 /* REFERENCES CALLED : */
680 /* ------------------- */
681
682 /* DESCRIPTION/NOTES/LIMITATIONS : */
683 /* ----------------------------------- */
684 /* > */
685 /* ***********************************************************************
686 */
687 /*
688 do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
689 do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
690 do__fio(&c__1, " sur l'allocation ", 18L);
691 do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
692 */
693
694 return 0 ;
695 } /* macrerr_ */
696
697
698 //=======================================================================
699 //function : macrgfl_
700 //purpose :
701 //=======================================================================
macrgfl_(intptr_t * iadfld,intptr_t * iadflf,integer * iphase,integer * iznuti)702 int macrgfl_(intptr_t *iadfld,
703 intptr_t *iadflf,
704 integer *iphase,
705 integer *iznuti)
706
707 {
708 /* Initialized data */
709
710 /* original code used static integer ifois=0 which served as static
711 initialization flag and was only used to call matrsym_() once; now
712 this flag is not used as matrsym_() always returns 0 and has no
713 useful contents
714 */
715 integer ifois = 1;
716
717 char cbid[1] = {};
718 integer ibid, ienr;
719 integer novfl = 0;
720
721 /* ***********************************************************************
722 */
723
724 /* FUNCTION : */
725 /* ---------- */
726 /* IMPLEMENTATION OF TWO FLAGS START AND END OF THE ALLOCATED ZONE */
727 /* AND SETTING TO OVERFLOW OF THE USER SPACE IN PHASE OF PRODUCTION. */
728
729 /* KEYWORDS : */
730 /* ----------- */
731 /* ALLOCATION, CONTROL, EXCESS */
732
733 /* INPUT ARGUMENTS : */
734 /* ------------------ */
735 /* IADFLD : ADDRESS OF THE START FLAG */
736 /* IADFLF : ADDRESS OF THE END FLAG */
737 /* IPHASE : TYPE OF SOFTWARE VERSION : */
738 /* 0 = OFFICIAL VERSION */
739 /* 1 = PRODUCTION VERSION */
740 /* IZNUTI : SIZE OF THE USER ZONE IN OCTETS */
741
742 /* OUTPUT ARGUMENTS : */
743 /* ------------------ */
744 /* NONE */
745
746 /* COMMONS USED : */
747 /* ------------------ */
748
749 /* REFERENCES CALLED : */
750 /* ------------------- */
751 /* CRLOCT,MACRCHK */
752
753 /* DESCRIPTION/NOTES/LIMITATIONS : */
754 /* ------------------------------- */
755
756 /* > */
757 /* ***********************************************************************
758 */
759
760
761
762 /* ***********************************************************************
763 */
764
765 /* FUNCTION : */
766 /* ---------- */
767 /* TABLE FOR MANAGEMENT OF DYNAMIC ALLOCATIONS OF MEMORY */
768
769 /* KEYWORDS : */
770 /* ----------- */
771 /* SYSTEM, MEMORY, ALLOCATION */
772
773 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
774 /* ----------------------------------- */
775
776
777 /* > */
778 /* ***********************************************************************
779 */
780 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
781 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
782 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
783 /* 2 : UNIT OF ALLOCATION */
784 /* 3 : NB OF ALLOCATED UNITS */
785 /* 4 : REFERENCE ADDRESS OF THE TABLE */
786 /* 5 : IOFSET */
787 /* 6 : STATIC ALLOCATION NUMBER */
788 /* 7 : Required allocation size */
789 /* 8 : address of the beginning of allocation */
790 /* 9 : Size of the USER ZONE */
791 /* 10 : ADDRESS of the START FLAG */
792 /* 11 : ADDRESS of the END FLAG */
793 /* 12 : Rank of creation of the allocation */
794
795 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
796 /* NCORE : NB OF CURRENT ALLOCS */
797 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
798 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
799
800
801
802
803
804 /* ----------------------------------------------------------------------*
805 */
806
807
808 if (ifois == 0) {
809 matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
810 ifois = 1;
811 }
812
813
814 /* CALCULATE THE OFFSET */
815 double* t = reinterpret_cast<double*>(*iadfld);
816
817 /* SET TO OVERFLOW OF THE USER ZONE IN CASE OF PRODUCTION VERSION */
818 if (*iphase == 1 && novfl == 0) {
819 ienr = *iznuti / 8;
820 maoverf_(&ienr, &t[1]);
821 }
822
823 /* UPDATE THE START FLAG */
824 *t = -134744073.;
825
826 /* FAKE CALL TO STOP THE DEBUGGER : */
827 macrbrk_();
828
829 /* UPDATE THE START FLAG */
830 t = reinterpret_cast<double*>(*iadflf);
831 *t = -134744073.;
832
833 /* FAKE CALL TO STOP THE DEBUGGER : */
834 macrbrk_();
835
836 return 0 ;
837 } /* macrgfl_ */
838
839 //=======================================================================
840 //function : macrmsg_
841 //purpose :
842 //=======================================================================
macrmsg_(const char *,integer *,integer * it,doublereal * xt,const char * ct,ftnlen,ftnlen ct_len)843 int macrmsg_(const char *,//crout,
844 integer *,//num,
845 integer *it,
846 doublereal *xt,
847 const char *ct,
848 ftnlen ,//crout_len,
849 ftnlen ct_len)
850
851 {
852
853 /* Local variables */
854 integer inum;
855 char /*cfm[80],*/ cln[3];
856
857 /* ***********************************************************************
858 */
859
860 /* FUNCTION : */
861 /* ---------- */
862 /* MESSAGING OF ROUTINES OF ALLOCATION */
863
864 /* KEYWORDS : */
865 /* ----------- */
866 /* ALLOC, MESSAGE */
867
868 /* INPUT ARGUMENTSEE : */
869 /* ------------------- */
870 /* CROUT : NAME OF THE CALLING ROUTINE : MCRRQST, MCRDELT, MCRLIST
871 */
872 /* ,CRINCR OR CRPROT */
873 /* NUM : MESSAGE NUMBER */
874 /* IT : TABLE OF INTEGER DATA */
875 /* XT : TABLE OF REAL DATA */
876 /* CT : ------------------ CHARACTER */
877
878 /* OUTPUT ARGUMENTS : */
879 /* --------------------- */
880 /* NONE */
881
882 /* COMMONS USED : */
883 /* ------------------ */
884
885 /* REFERENCES CALLED : */
886 /* --------------------- */
887
888 /* DESCRIPTION/NOTES/LIMITATIONS : */
889 /* ----------------------------------- */
890
891 /* ROUTINE FOR TEMPORARY USE, WAITING FOR THE 'NEW' MESSAGE */
892 /* (STRIM 3.3 ?), TO MAKE THE ROUTINES OF ALLOC USABLE */
893 /* IN STRIM T-M . */
894
895 /* DEPENDING ON THE LANGUAGE, WRITING OF THE REQUIRED MESSAGE ON */
896 /* UNIT IMP . */
897 /* (REUSE OF SPECIFS OF VFORMA) */
898
899 /* THE MESSAGE IS INITIALIZED AT 'MESSAGE MISSING', AND IT IS */
900 /* REPLACED BY THE REQUIRED MESSAGE IF EXISTS. */
901 /* > */
902 /* ***********************************************************************
903 */
904
905 /* LOCAL : */
906
907 /* ----------------------------------------------------------------------*
908 */
909 /* FIND MESSAGE DEPENDING ON THE LANGUAGE , THE ROUTINE */
910 /* AND THE MESSAGE NUMBER */
911
912 /* READING OF THE LANGUAGE : */
913 /* Parameter adjustments */
914 ct -= ct_len;
915 (void )ct; // unused
916
917 --xt;
918 --it;
919
920 /* Function Body */
921 mamdlng_(cln, 3L);
922
923 /* INUM : TYPE OF MESSAGE : 0 AS TEXT, 1 1 INTEGER TO BE WRITTEN */
924 /* -1 MESSAGE INEXISTING (1 INTEGER AND 1 CHAIN) */
925
926 inum = -1;
927 /*
928 if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
929 __s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
930 e de nom : ',A8)", 80L, 71L);
931 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
932 if (*num == 1) {
933 inum = 1;
934 __s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
935 ee(s) : ',I6,/)", 80L, 62L);
936 } else if (*num == 2) {
937 inum = 1;
938 __s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
939 } else if (*num == 3) {
940 inum = 1;
941 __s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
942 }
943 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
944 if (*num == 1) {
945 inum = 0;
946 __s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
947 e pas ')", 80L, 56L);
948 } else if (*num == 2) {
949 inum = 0;
950 __s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
951 ion de memoire ')", 80L, 65L);
952 }
953 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
954 if (*num == 1) {
955 inum = 1;
956 __s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
957 atteint :',I6)", 80L, 62L);
958 } else if (*num == 2) {
959 inum = 1;
960 __s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
961 40L);
962 } else if (*num == 3) {
963 inum = 1;
964 __s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
965 de ',I12,' octets')", 80L, 66L);
966 }
967 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
968 if (*num == 1) {
969 inum = 0;
970 __s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
971 iste pas')", 80L, 57L);
972 }
973 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
974 if (*num == 1) {
975 inum = 1;
976 __s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
977 ) : ',I12)", 80L, 57L);
978 }
979 }
980
981 } else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
982 __s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
983 mm des Namens : ',A8)", 80L, 76L);
984 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
985 if (*num == 1) {
986 inum = 1;
987 __s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
988 sung(en) : ',I6,/)", 80L, 65L);
989 } else if (*num == 2) {
990 inum = 1;
991 __s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
992 } else if (*num == 3) {
993 inum = 1;
994 __s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
995 41L);
996 }
997 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
998 if (*num == 1) {
999 inum = 0;
1000 __s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
1001 nicht !! ')", 80L, 59L);
1002 } else if (*num == 2) {
1003 inum = 0;
1004 __s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
1005 Zuweisung !!')", 80L, 61L);
1006 }
1007 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1008 if (*num == 1) {
1009 inum = 1;
1010 __s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
1011 icht :',I6)", 80L, 58L);
1012 } else if (*num == 2) {
1013 inum = 1;
1014 __s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
1015 ;
1016 } else if (*num == 3) {
1017 inum = 1;
1018 __s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
1019 ,I12,' Bytes')", 80L, 61L);
1020 }
1021 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1022 if (*num == 1) {
1023 inum = 0;
1024 __s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
1025 stiert nicht !! ')", 80L, 65L);
1026 }
1027 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1028 if (*num == 1) {
1029 inum = 1;
1030 __s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
1031 : ',I12)", 80L, 55L);
1032 }
1033 }
1034
1035 } else {
1036 __s__copy(cfm, "(' Message number ',I5,' is missing ' \
1037 ,'for program named: ',A8)", 80L, 93L);
1038 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1039 if (*num == 1) {
1040 inum = 1;
1041 __s__copy(cfm, "(/,' number of memory allocations carried out: \
1042 ',I6,/)", 80L, 54L);
1043 } else if (*num == 2) {
1044 inum = 1;
1045 __s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
1046 } else if (*num == 3) {
1047 inum = 1;
1048 __s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
1049 }
1050 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1051 if (*num == 1) {
1052 inum = 0;
1053 __s__copy(cfm, "(' Memory allocation to delete does not exist !\
1054 ! ')", 80L, 51L);
1055 } else if (*num == 2) {
1056 inum = 0;
1057 __s__copy(cfm, "(' System refuses deletion of memory allocation\
1058 !! ')", 80L, 53L);
1059 }
1060 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1061 if (*num == 1) {
1062 inum = 1;
1063 __s__copy(cfm, "(' max number of memory allocations reached :',\
1064 I6)", 80L, 50L);
1065 } else if (*num == 2) {
1066 inum = 1;
1067 __s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
1068 40L);
1069 } else if (*num == 3) {
1070 inum = 1;
1071 __s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
1072 ' bytes ')", 80L, 57L);
1073 }
1074 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1075 if (*num == 1) {
1076 inum = 0;
1077 __s__copy(cfm, "(' Memory allocation to increment does not exis\
1078 t !! ')", 80L, 54L);
1079 }
1080 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1081 if (*num == 1) {
1082 inum = 1;
1083 __s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
1084 ',I12)", 80L, 53L);
1085 }
1086 }
1087 }
1088 */
1089 /* ----------------------------------------------------------------------*
1090 */
1091 /* iMPLEMENTATION OF WRITE , WITH OR WITHOUT DATA : */
1092
1093 if (inum == 0) {
1094 } else if (inum == 1) {
1095 /*
1096 do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
1097 */
1098 } else {
1099 /* MESSAGE DOES NOT EXIST ... */
1100 /*
1101 do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
1102 do__fio(&c__1, crout, crout_len);
1103 */
1104 }
1105
1106 return 0;
1107 } /* macrmsg_ */
1108 //=======================================================================
1109 //function : macrstw_
1110 //purpose :
1111 //=======================================================================
macrstw_(intptr_t *,intptr_t *,integer *)1112 int macrstw_(intptr_t *,//iadfld,
1113 intptr_t *,//iadflf,
1114 integer *)//nalloc)
1115
1116 {
1117 return 0 ;
1118 } /* macrstw_ */
1119
1120 //=======================================================================
1121 //function : madbtbk_
1122 //purpose :
1123 //=======================================================================
madbtbk_(integer * indice)1124 int madbtbk_(integer *indice)
1125 {
1126 *indice = 0;
1127 return 0 ;
1128 } /* madbtbk_ */
1129
1130 //=======================================================================
1131 //function : AdvApp2Var_SysBase::maermsg_
1132 //purpose :
1133 //=======================================================================
maermsg_(const char *,integer *,ftnlen)1134 int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
1135 integer *,//icoder,
1136 ftnlen )//cnompg_len)
1137
1138 {
1139 return 0 ;
1140 } /* maermsg_ */
1141
1142 //=======================================================================
1143 //function : magtlog_
1144 //purpose :
1145 //=======================================================================
magtlog_(const char * cnmlog,const char *,integer * long__,integer * iercod,ftnlen cnmlog_len,ftnlen)1146 int magtlog_(const char *cnmlog,
1147 const char *,//chaine,
1148 integer *long__,
1149 integer *iercod,
1150 ftnlen cnmlog_len,
1151 ftnlen )//chaine_len)
1152
1153 {
1154
1155 /* Local variables */
1156 char cbid[255];
1157 integer ibid, ier;
1158
1159
1160 /* **********************************************************************
1161 */
1162
1163 /* FUNCTION : */
1164 /* ---------- */
1165 /* RETURN TRANSLATION OF "NAME LOGIC STRIM" IN */
1166 /* "INTERNAL SYNTAX" CORRESPONDING TO "PLACE OF RANKING" */
1167
1168 /* KEYWORDS : */
1169 /* ----------- */
1170 /* NOM LOGIQUE STRIM , TRADUCTION */
1171
1172 /* INPUT ARGUMENTS : */
1173 /* ------------------ */
1174 /* CNMLOG : NAME OF "NAME LOGIC STRIM" TO TRANSLATE */
1175
1176 /* OUTPUT ARGUMENTS : */
1177 /* ------------------- */
1178 /* CHAINE : ADDRESS OF "PLACE OF RANKING" */
1179 /* LONG : USEFUL LENGTH OF "PLACE OF RANKING" */
1180 /* IERCOD : ERROR CODE */
1181 /* IERCOD = 0 : OK */
1182 /* IERCOD = 5 : PLACE OF RANKING CORRESPONDING TO INEXISTING LOGIC NAME */
1183
1184 /* IERCOD = 6 : TRANSLATION TOO LONG FOR THE 'CHAIN' VARIABLE */
1185 /* IERCOD = 7 : CRITICAL ERROR */
1186
1187 /* COMMONS USED : */
1188 /* ---------------- */
1189 /* NONE */
1190
1191 /* REFERENCES CALLED : */
1192 /* --------------------- */
1193 /* GNMLOG, MACHDIM */
1194
1195 /* DESCRIPTION/NOTES/LIMITATIONS : */
1196 /* ------------------------------- */
1197
1198 /* SPECIFIC SGI ROUTINE */
1199
1200 /* IN ALL CASES WHEN IERCOD IS >0, NO RESULT IS RETURNED*/
1201 /* NOTION OF "USER SYNTAX' AND "INTERNAL SYNTAX" */
1202 /* --------------------------------------------------- */
1203
1204 /* THE "USER SYNTAX" IS THE SYNTAX WHERE THE USER*/
1205 /* VISUALIZES OR INDICATES THE FILE OR DIRECTORY NAME */
1206 /* DURING A SESSION OF STRIM100 */
1207
1208 /* "INTERNAL SYNTAX" IS SYNTAX USED TO CARRY OUT */
1209 /* OPERATIONS OF FILE PROCESSING INSIDE THE CODE */
1210 /* (OPEN,INQUIRE,...ETC) */
1211
1212 /* > */
1213 /* ***********************************************************************
1214 */
1215 /* DECLARATIONS */
1216 /* ***********************************************************************
1217 */
1218
1219
1220 /* ***********************************************************************
1221 */
1222 /* PROCESSING */
1223 /* ***********************************************************************
1224 */
1225
1226 *long__ = 0;
1227 *iercod = 0;
1228
1229 /* CONTROL OF EXISTENCE OF THE LOGIC NAME */
1230
1231 matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
1232 if (ier == 1) {
1233 goto L9500;
1234 }
1235 if (ier == 2) {
1236 goto L9700;
1237 }
1238
1239 /* CONTROL OF THE LENGTH OF CHAIN */
1240
1241 if (ibid > __i__len()/*chaine, chaine_len)*/) {
1242 goto L9600;
1243 }
1244
1245 //__s__copy(chaine, cbid, chaine_len, ibid);
1246 *long__ = ibid;
1247
1248 goto L9999;
1249
1250 /* ***********************************************************************
1251 */
1252 /* ERROR PROCESSING */
1253 /* ***********************************************************************
1254 */
1255
1256 L9500:
1257 *iercod = 5;
1258 //__s__copy(chaine, " ", chaine_len, 1L);
1259 goto L9999;
1260
1261 L9600:
1262 *iercod = 6;
1263 //__s__copy(chaine, " ", chaine_len, 1L);
1264 goto L9999;
1265
1266 L9700:
1267 *iercod = 7;
1268 //__s__copy(chaine, " ", chaine_len, 1L);
1269
1270 /* ***********************************************************************
1271 */
1272 /* RETURN TO THE CALLING PROGRAM */
1273 /* ***********************************************************************
1274 */
1275
1276 L9999:
1277 return 0;
1278 } /* magtlog_ */
1279
1280 //=======================================================================
1281 //function : mainial_
1282 //purpose :
1283 //=======================================================================
mainial_()1284 int AdvApp2Var_SysBase::mainial_()
1285 {
1286 mcrgene_.ncore = 0;
1287 mcrgene_.lprot = 0;
1288 return 0 ;
1289 } /* mainial_ */
1290
1291 //=======================================================================
1292 //function : AdvApp2Var_SysBase::maitbr8_
1293 //purpose :
1294 //=======================================================================
maitbr8_(integer * itaill,doublereal * xtab,doublereal * xval)1295 int AdvApp2Var_SysBase::maitbr8_(integer *itaill,
1296 doublereal *xtab,
1297 doublereal *xval)
1298
1299 {
1300 integer c__504 = 504;
1301
1302 /* Initialized data */
1303
1304 doublereal buff0[63] = {
1305 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1306 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1307 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1308 0.,0.,0.,0.,0.
1309 };
1310
1311 /* System generated locals */
1312 integer i__1;
1313
1314 /* Local variables */
1315 integer i__;
1316 doublereal buffx[63];
1317 integer nbfois, noffst, nreste, nufois;
1318
1319 /* ***********************************************************************
1320 */
1321
1322 /* FUNCTION : */
1323 /* ---------- */
1324 /* INITIALIZATION TO A GIVEN VALUE OF A TABLE OF REAL *8 */
1325
1326 /* KEYWORDS : */
1327 /* ----------- */
1328 /* MANIPULATIONS, MEMORY, INITIALIZATION, DOUBLE-PRECISION */
1329
1330 /* INPUT ARGUMENTS : */
1331 /* ----------------- */
1332 /* ITAILL : SIZE OF THE TABLE */
1333 /* XTAB : TABLE TO INITIALIZE WITH XVAL */
1334 /* XVAL : VALUE TO SET IN XTAB(FROM 1 TO ITAILL) */
1335
1336 /* OUTPUT ARGUMENTS : */
1337 /* ------------------ */
1338 /* XTAB : INITIALIZED TABLE */
1339
1340 /* COMMONS USED : */
1341 /* -------------- */
1342
1343 /* REFERENCES CALLED : */
1344 /* ------------------- */
1345
1346 /* DESCRIPTION/NOTES/LIMITATIONS : */
1347 /* ----------------------------------- */
1348
1349 /* ONE CALLS MCRFILL WHICH MOVES BY PACKS OF 63 REALS */
1350
1351 /* THE INITIAL PACK IS BUFF0 INITIATED BY DATA IF THE VALUE IS 0 */
1352 /* OR OTHERWISE BUFFX INITIATED BY XVAL (LOOP). */
1353
1354
1355 /* PORTABILITY : YES */
1356 /* ACCESS : FREE */
1357
1358
1359 /* > */
1360 /* ***********************************************************************
1361 */
1362
1363
1364 /* Parameter adjustments */
1365 --xtab;
1366
1367 /* Function Body */
1368
1369 /* ----------------------------------------------------------------------*
1370 */
1371
1372 nbfois = *itaill / 63;
1373 noffst = nbfois * 63;
1374 nreste = *itaill - noffst;
1375
1376 if (*xval == 0.) {
1377 if (nbfois >= 1) {
1378 i__1 = nbfois;
1379 for (nufois = 1; nufois <= i__1; ++nufois) {
1380 AdvApp2Var_SysBase::mcrfill_(&c__504, buff0, &xtab[(nufois - 1) * 63 + 1]);
1381 /* L1000: */
1382 }
1383 }
1384
1385 if (nreste >= 1) {
1386 i__1 = nreste << 3;
1387 AdvApp2Var_SysBase::mcrfill_(&i__1, buff0, &xtab[noffst + 1]);
1388 }
1389 } else {
1390 for (i__ = 1; i__ <= 63; ++i__) {
1391 buffx[i__ - 1] = *xval;
1392 /* L2000: */
1393 }
1394 if (nbfois >= 1) {
1395 i__1 = nbfois;
1396 for (nufois = 1; nufois <= i__1; ++nufois) {
1397 AdvApp2Var_SysBase::mcrfill_(&c__504, buffx, &xtab[(nufois - 1) * 63 + 1]);
1398 /* L3000: */
1399 }
1400 }
1401
1402 if (nreste >= 1) {
1403 i__1 = nreste << 3;
1404 AdvApp2Var_SysBase::mcrfill_(&i__1, buffx, &xtab[noffst + 1]);
1405 }
1406 }
1407
1408 /* ----------------------------------------------------------------------*
1409 */
1410
1411 return 0;
1412 } /* maitbr8_ */
1413
1414 //=======================================================================
1415 //function : mamdlng_
1416 //purpose :
1417 //=======================================================================
mamdlng_(char *,ftnlen)1418 int mamdlng_(char *,//cmdlng,
1419 ftnlen )//cmdlng_len)
1420
1421 {
1422
1423
1424 /* ***********************************************************************
1425 */
1426
1427 /* FUNCTION : */
1428 /* ---------- */
1429 /* RETURN THE CURRENT LANGUAGE */
1430
1431 /* KEYWORDS : */
1432 /* ----------- */
1433 /* MANAGEMENT, CONFIGURATION, LANGUAGE, READING */
1434
1435 /* INPUT ARGUMENTS : */
1436 /* -------------------- */
1437 /* CMDLNG : LANGUAGE */
1438
1439 /* OUTPUT ARGUMENTS : */
1440 /* ------------------- */
1441 /* NONE */
1442
1443 /* COMMONS USED : */
1444 /* ------------------ */
1445 /* MACETAT */
1446
1447 /* REFERENCES CALLED : */
1448 /* --------------------- */
1449 /* NONE */
1450
1451 /* DESCRIPTION/NOTES/LIMITATIONS : */
1452 /* ----------------------------------- */
1453 /* RIGHT OF USAGE : ANY APPLICATION */
1454
1455 /* ATTENTION : THIS ROUTINE DEPENDS ON PRELIMINARY INITIALISATION */
1456 /* ---------- WITH AMDGEN. */
1457 /* SO IT IS ENOUGH TO PROVIDE THAT THIS INIT IS */
1458 /* CORRECTLY IMPLEMENTED IN THE RESPECTIVE PROGRAMS */
1459 /* > */
1460 /* ***********************************************************************
1461 */
1462
1463
1464 /* INCLUDE MACETAT */
1465 /* < */
1466
1467 /* ***********************************************************************
1468 */
1469
1470 /* FUNCTION : */
1471 /* ---------- */
1472 /* CONTAINS INFORMATION ABOUT THE COMPOSITION OF */
1473 /* THE EXECUTABLE AND ITS ENVIRONMENT : */
1474 /* - LANGUAGES */
1475 /* - PRESENT APPLICATIONS */
1476 /* - AUTHORIZED TYPES OF ENTITIES (NON USED) */
1477 /* AND INFORMATION DESCRIBING THE CURRENT STATE : */
1478 /* - CURRENT APPLICATION */
1479 /* - MODE OF USAGE (NOT USED) */
1480
1481 /* KEYWORDS : */
1482 /* ----------- */
1483 /* APPLICATION, LANGUAGE */
1484
1485 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
1486 /* ----------------------------------- */
1487
1488 /* A) CHLANG*4 : LIST OF POSSIBLE VALUES OF THE LANGUAGE : */
1489 /* 'FRA ','DEU ','ENG ' */
1490
1491 /* CHL10N*4 : LIST OF POSSIBLE VALUES OF THE LOCALIZATION : */
1492 /* 'FRA ','DEU ','ENG ', 'JIS ' */
1493
1494 /* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : CURRENT, PREVIOUS AND NEXT APPLICATION */
1495
1496 /* C) CHMODE*4 : CURRENT MODE (NOT USED) */
1497
1498 /* D) CHPRES*2 (1:NBRMOD) : LIST OF APPLICATIONS TAKEN INTO ACCOUNT */
1499
1500 /* Rang ! Code interne ! Application */
1501 /* ---------------------------------------------------------- */
1502 /* 1 ! CD ! Modeling 2D */
1503 /* 2 ! CA ! Modeling 2D by learning */
1504 /* 3 ! CP ! Parameterized 2D modelization */
1505 /* 4 ! PC ! Rheological 2D modelization */
1506 /* 5 ! CU ! Milling 2 Axes 1/2 */
1507 /* 6 ! CT ! Turning */
1508 /* 7 ! TS ! 3D surface modeling */
1509 /* 8 ! TV ! 3D volume modeling */
1510 /* 9 ! MC ! Surface Meshing */
1511 /* 10 ! MV ! Volume Meshing */
1512 /* 11 ! TU ! Machining by 3 axes */
1513 /* 12 ! T5 ! Machining by 3-5 axes */
1514 /* 13 ! TR ! Machinning by 5 axes of regular surfaces */
1515 /* 14 ! IG ! Interface IGES */
1516 /* 15 ! ST ! Interface SET */
1517 /* 16 ! VD ! Interface VDA */
1518 /* 17 ! IM ! Interface of modeling */
1519 /* 18 ! GA ! Generator APT/IFAPT */
1520 /* 19 ! GC ! Generator COMPACT II */
1521 /* 20 ! GP ! Generator PROMO */
1522 /* 21 ! TN ! Machining by numerical copying */
1523 /* 22 ! GM ! Management of models */
1524 /* 23 ! GT ! Management of trace */
1525 /* ---------------------------------------------------------- */
1526
1527
1528
1529 /* > */
1530 /* ***********************************************************************
1531 */
1532
1533 /* NUMBER OF APPLICATIONS TAKEN INTO ACCOUNT */
1534
1535
1536 /* NUMBER OF ENTITY TYPES MANAGED BY STRIM 100 */
1537 //__s__copy(cmdlng, macetat_.chlang, cmdlng_len, 4L);
1538
1539 return 0 ;
1540 } /* mamdlng_ */
1541
1542 //=======================================================================
1543 //function : maostrb_
1544 //purpose :
1545 //=======================================================================
maostrb_()1546 int maostrb_()
1547 {
1548 return 0 ;
1549 } /* maostrb_ */
1550
1551 //=======================================================================
1552 //function : maostrd_
1553 //purpose :
1554 //=======================================================================
maostrd_()1555 int maostrd_()
1556 {
1557 integer imod;
1558
1559 /* ***********************************************************************
1560 */
1561
1562 /* FUNCTION : */
1563 /* ---------- */
1564 /* REFINE TRACE-BACK IN PRODUCTION PHASE */
1565
1566 /* KEYWORDS : */
1567 /* ----------- */
1568 /* FUNCTION, SYSTEM, TRACE-BACK, REFINING, DEBUG */
1569
1570 /* INPUT ARGUMENTS : */
1571 /* ----------------- */
1572 /* NONE */
1573
1574 /* OUTPUT ARGUMENTS E : */
1575 /* -------------------- */
1576 /* NONE */
1577
1578 /* COMMONS USED : */
1579 /* -------------- */
1580 /* NONE */
1581
1582 /* REFERENCES CALLED : */
1583 /* ------------------- */
1584 /* MADBTBK */
1585
1586 /* DESCRIPTION/NOTES/LIMITATIONS : */
1587 /* ----------------------------------- */
1588 /* THIS ROUTINE SHOULD BE CALLED TO REFINE */
1589 /* TRACE-BACK IN PRODUCTION PHASE AND LEAVE TO TESTERS THE */
1590 /* POSSIBILITY TO GET TRACE-BACK IN */
1591 /* CLIENT VERSIONS IF ONE OF THE FOLLOWING CONDITIONS IS */
1592 /* VERIFIED : */
1593 /* - EXISTENCE OF SYMBOL 'STRMTRBK' */
1594 /* - EXISTENCE OF FILE 'STRMINIT:STRMTRBK.DAT' */
1595
1596
1597 /* > */
1598 /* ***********************************************************************
1599 */
1600 madbtbk_(&imod);
1601 if (imod == 1) {
1602 maostrb_();
1603 }
1604 return 0 ;
1605 } /* maostrd_ */
1606
1607 //=======================================================================
1608 //function : maoverf_
1609 //purpose :
1610 //=======================================================================
maoverf_(integer * nbentr,doublereal * dtable)1611 int maoverf_(integer *nbentr,
1612 doublereal *dtable)
1613
1614 {
1615 /* Initialized data */
1616
1617 integer ifois = 0;
1618
1619 /* System generated locals */
1620 integer i__1;
1621
1622 /* Local variables */
1623 integer ibid;
1624 doublereal buff[63];
1625 integer ioct, indic, nrest, icompt;
1626
1627 /* ***********************************************************************
1628 */
1629
1630 /* FUNCTION : */
1631 /* ---------- */
1632 /* Initialisation in overflow of a tableau with DOUBLE PRECISION */
1633
1634 /* KEYWORDS : */
1635 /* ----------- */
1636 /* MANIPULATION, MEMORY, INITIALISATION, OVERFLOW */
1637
1638 /* INPUT ARGUMENTS : */
1639 /* ----------------- */
1640 /* NBENTR : Number of entries in the table */
1641
1642 /* OUTPUT ARGUMENTS : */
1643 /* ------------------ */
1644 /* DATBLE : Table double precision initialized in overflow */
1645
1646 /* COMMONS USED : */
1647 /* ------------------ */
1648 /* R8OVR contained in the include MAOVPAR.INC */
1649
1650 /* REFERENCES CALLED : */
1651 /* --------------------- */
1652 /* MCRFILL */
1653
1654 /* DESCRIPTION/NOTES/LIMITATIONS : */
1655 /* ----------------------------------- */
1656 /* 1) Doc. programmer : */
1657
1658 /* This routine initialized to positive overflow a table with */
1659 /* DOUBLE PRECISION. */
1660
1661 /* Other types of tables (INTEGER*2, INTEGER, REAL, ...) */
1662 /* are not managed by the routine. */
1663
1664 /* It is usable in phase of development to detect the */
1665 /* errors of initialization. */
1666
1667 /* In official version, these calls will be inactive. */
1668
1669 /* ACCESs : Agreed with AC. */
1670
1671 /* The routine does not return error code. */
1672
1673 /* Argument NBELEM should be positive. */
1674 /* If it is negative or null, display message "MAOVERF : NBELEM = */
1675 /* valeur_de_NBELEM" and a Trace Back by the call of routine MAOSTRB. */
1676
1677
1678 /* 2) Doc. designer : */
1679
1680 /* The idea is to minimize the number of calls */
1681 /* to the routine of transfer of numeric zones, */
1682 /* ---------- for the reason of performance. */
1683 /* ! buffer ! For this a table of NLONGR */
1684 /* !__________! DOUBLE PRECISIONs is reserved. This buffer is initialized by */
1685 /* <----------> the instruction DATA. The overflow is accessed in a */
1686 /* NLONGR*8 specific COMMON not by a routine as */
1687 /* the initialisation is done by DATA. */
1688
1689 /* * If NBENTR<NLONGR, a part of the buffer is transferred*/
1690 /* DTABLE in DTABLE. */
1691 /* __________ */
1692 /* ! amorce ! * Otherwise, the entire buffer is transferred in DTABLE. */
1693 /* !__________! This initiates it. Then a loop is execute, which at each
1694 */
1695 /* ! temps 1 ! iteration transfers the part of the already initialized table */
1696 /* !__________! in the one that was not yet initialized. */
1697 /* ! ! The size of the zone transferred by each call to MCRFILL
1698 */
1699 /* ! temps 2 ! is NLONGR*2**(numero_de_l'iteration). When
1700 */
1701 /* ! ! the size of the table to be initialized is */
1702 /* !__________! less than the already initialized size, the loop is */
1703 /* ! ! abandoned and thev last transfer is carried out to */
1704 /* ! ! initialize the remaining table, except for the case when the size */
1705 /* ! ! of the table is of type NLONGR*2**K. */
1706 /* ! temps 3 ! */
1707 /* ! ! * NLONGR will be equal to 19200. */
1708 /* ! ! */
1709 /* ! ! */
1710 /* !__________! */
1711 /* ! reste ! */
1712 /* !__________! */
1713
1714
1715 /* > */
1716 /* ***********************************************************************
1717 */
1718
1719 /* Inclusion of MAOVPAR.INC */
1720
1721 /* CONSTANTS */
1722 /* INCLUDE MAOVPAR */
1723 /* ***********************************************************************
1724 */
1725
1726 /* FUNCTION : */
1727 /* ---------- */
1728 /* DEFINES SPECIFIC LIMITED VALUES. */
1729
1730 /* KEYWORDS : */
1731 /* ----------- */
1732 /* SYSTEM, LIMITS, VALUES, SPECIFIC */
1733
1734 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
1735 /* ----------------------------------- */
1736 /* *** THEY CAN'T BE REMOVED DURING EXECUTION. */
1737
1738 /* *** THE VALUES OF UNDERFLOW AND OVERFLOW CAN'T BE */
1739 /* DEFINED IN DECIMAL VALUES (ERROR OF COMPILATION D_FLOAT) */
1740 /* THEY ARE DEFINED AS HEXADECIMAL VALUES */
1741
1742
1743 /* > */
1744 /* ***********************************************************************
1745 */
1746
1747
1748 /* DECLARATION OF THE COMMON FOR NUMERIC TYPES */
1749
1750
1751 /* DECLARATION OF THE COMMON FOR CHARACTER TYPES*/
1752
1753
1754
1755 /* LOCAL VARIABLES */
1756
1757 /* TABLES */
1758
1759 /* DATA */
1760 /* Parameter adjustments */
1761 --dtable;
1762
1763 /* Function Body */
1764
1765 /* vJMB R8OVR IS NOT YET initialized, so impossible to use DATA
1766 */
1767 /* DATA BUFF / NLONGR * R8OVR / */
1768
1769 /* init of BUFF is done only once */
1770
1771 if (ifois == 0) {
1772 for (icompt = 1; icompt <= 63; ++icompt) {
1773 buff[icompt - 1] = maovpar_.r8ovr;
1774 /* L20: */
1775 }
1776 ifois = 1;
1777 }
1778
1779 /* ^JMB */
1780 /* Exception */
1781 if (*nbentr < 63) {
1782 nrest = *nbentr << 3;
1783 AdvApp2Var_SysBase::mcrfill_(&nrest, buff, &dtable[1]);
1784 } else {
1785
1786 /* Start & initialization */
1787 ioct = 504;
1788 AdvApp2Var_SysBase::mcrfill_(&ioct, buff, &dtable[1]);
1789 indic = 63;
1790
1791 /* Loop. The upper limit is the integer value of the logarithm of base 2
1792 */
1793 /* of NBENTR/NLONGR. */
1794 i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.))
1795 ;
1796 for (ibid = 1; ibid <= i__1; ++ibid) {
1797
1798 AdvApp2Var_SysBase::mcrfill_(&ioct, &dtable[1], &dtable[indic + 1]);
1799 ioct += ioct;
1800 indic += indic;
1801
1802 /* L10: */
1803 }
1804
1805 nrest = ( *nbentr - indic ) << 3;
1806
1807 if (nrest > 0) {
1808 AdvApp2Var_SysBase::mcrfill_(&nrest, &dtable[1], &dtable[indic + 1]);
1809 }
1810
1811 }
1812 return 0 ;
1813 } /* maoverf_ */
1814
1815 //=======================================================================
1816 //function : AdvApp2Var_SysBase::maovsr8_
1817 //purpose :
1818 //=======================================================================
maovsr8_(integer * ivalcs)1819 int AdvApp2Var_SysBase::maovsr8_(integer *ivalcs)
1820 {
1821 *ivalcs = maovpar_.r8ncs;
1822 return 0 ;
1823 } /* maovsr8_ */
1824
1825 //=======================================================================
1826 //function : matrlog_
1827 //purpose :
1828 //=======================================================================
matrlog_(const char *,const char *,integer * length,integer * iercod,ftnlen,ftnlen)1829 int matrlog_(const char *,//cnmlog,
1830 const char *,//chaine,
1831 integer *length,
1832 integer *iercod,
1833 ftnlen ,//cnmlog_len,
1834 ftnlen )//chaine_len)
1835
1836 {
1837 *iercod = 1;
1838 *length = 0;
1839
1840 return 0 ;
1841 } /* matrlog_ */
1842
1843 //=======================================================================
1844 //function : matrsym_
1845 //purpose :
1846 //=======================================================================
matrsym_(const char * cnmsym,const char *,integer * length,integer * iercod,ftnlen cnmsym_len,ftnlen)1847 int matrsym_(const char *cnmsym,
1848 const char *,//chaine,
1849 integer *length,
1850 integer *iercod,
1851 ftnlen cnmsym_len,
1852 ftnlen )//chaine_len)
1853
1854 {
1855 /* Local variables */
1856 char chainx[255] = {};
1857
1858 /* ***********************************************************************
1859 */
1860
1861 /* FUNCTION : */
1862 /* ---------- */
1863 /* RETURN THE VALUE OF A SYMBOL DEFINED DURING THE */
1864 /* INITIALISATION OF A USER */
1865
1866 /* KEYWORDS : */
1867 /* ----------- */
1868 /* TRANSLATION, SYMBOL */
1869
1870 /* INPUT ARGUMENTS : */
1871 /* -------------------- */
1872 /* CNMSYM : NAME OF THE SYMBOL */
1873
1874 /* OUTPUT ARGUMENTS : */
1875 /* ------------------ */
1876 /* CHAINE : TRANSLATION OF THE SYMBOL */
1877 /* LENGTH : USEFUL LENGTH OF THE CHAIN */
1878 /* IERCOD : ERROR CODE */
1879 /* = 0 : OK */
1880 /* = 1 : INEXISTING SYMBOL */
1881 /* = 2 : OTHER ERROR */
1882
1883 /* COMMONS USED : */
1884 /* ------------------ */
1885 /* NONE */
1886
1887 /* REFERENCES CALLED : */
1888 /* --------------------- */
1889 /* LIB$GET_SYMBOL,MACHDIM */
1890
1891 /* DESCRIPTION/NOTES/LIMITATIONS : */
1892 /* ----------------------------------- */
1893 /* - THIS ROUTINE IS VAX SPECIFIC */
1894 /* - IN CASE OF ERROR (IERCOD>0), CHAIN = ' ' AND LENGTH = 0 */
1895 /* - IF THE INPUT VARIABLE CNMSYM IS EMPTY, THE ROUTINE RETURNS IERCOD=1*/
1896 /* > */
1897 /* ***********************************************************************
1898 */
1899
1900
1901 /* SGI...v */
1902
1903 /* SGI CALL MAGTLOG (CNMSYM,CHAINE,LENGTH,IERCOD) */
1904 magtlog_(cnmsym, chainx, length, iercod, cnmsym_len, 255L);
1905 /* SO...v */
1906 if (*iercod == 5) {
1907 *iercod = 1;
1908 }
1909 /* SO...^ */
1910 if (*iercod >= 2) {
1911 *iercod = 2;
1912 }
1913 //if (__s__cmp(chainx, "NONE", 255L, 4L) == 0) {
1914 if (__s__cmp() == 0) {
1915 //__s__copy(chainx, " ", 255L, 1L);
1916 *length = 0;
1917 }
1918 //__s__copy(chaine, chainx, chaine_len, 255L);
1919 /* SGI...^ */
1920
1921
1922 /* ***********************************************************************
1923 */
1924 /* ERROR PROCESSING */
1925 /* ***********************************************************************
1926 */
1927
1928
1929 /* L9999: */
1930 return 0;
1931 } /* matrsym_ */
1932
1933 //=======================================================================
1934 //function : mcrcomm_
1935 //purpose :
1936 //=======================================================================
mcrcomm_(integer * kop,integer * noct,intptr_t * iadr,integer * ier)1937 int mcrcomm_(integer *kop,
1938 integer *noct,
1939 intptr_t *iadr,
1940 integer *ier)
1941
1942 {
1943 /* Initialized data */
1944
1945 integer ntab = 0;
1946
1947 /* System generated locals */
1948 integer i__1, i__2;
1949
1950 /* Local variables */
1951 intptr_t ideb;
1952 doublereal dtab[32000];
1953 intptr_t itab[160] /* was [4][40] */;
1954 intptr_t ipre;
1955 integer i__, j, k;
1956
1957
1958 /************************************************************************
1959 *******/
1960
1961 /* FUNCTION : */
1962 /* ---------- */
1963 /* DYNAMIC ALLOCATION ON COMMON */
1964
1965 /* KEYWORDS : */
1966 /* ----------- */
1967 /* . ALLOCDYNAMIQUE, MEMORY, COMMON, ALLOC */
1968
1969 /* INPUT ARGUMENTS : */
1970 /* ------------------ */
1971 /* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */
1972 /* NOCT : NUMBER OF OCTETS */
1973
1974 /* OUTPUT ARGUMENTS : */
1975 /* ------------------- */
1976 /* IADR : ADDRESS IN MEMORY OF THE FIRST OCTET */
1977 /* * : */
1978 /* * : */
1979 /* IERCOD : ERROR CODE */
1980
1981 /* IERCOD = 0 : OK */
1982 /* IERCOD > 0 : CRITICAL ERROR */
1983 /* IERCOD < 0 : WARNING */
1984 /* IERCOD = 1 : ERROR DESCRIPTION */
1985 /* IERCOD = 2 : ERROR DESCRIPTION */
1986
1987 /* COMMONS USED : */
1988 /* ---------------- */
1989
1990 /* CRGEN2 */
1991
1992 /* REFERENCES CALLED : */
1993 /* ---------------------- */
1994
1995 /* Type Name */
1996 /* MCRLOCV */
1997
1998 /* DESCRIPTION/NOTES/LIMITATIONS : */
1999 /* ----------------------------------- */
2000
2001 /* ATTENTION .... ITAB ARE NTAB NOT SAVED BETWEEN 2 CALLS..
2002 */
2003
2004 /* > */
2005 /* ***********************************************************************
2006 */
2007
2008 /* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */
2009
2010 /* ITAB : TABLE OF MANAGEMENT OF DTAB, ALLOCATED MEMORY ZONE . */
2011 /* NTAB : NUMBER OF COMPLETED ALLOCATIONS. */
2012 /* FORMAT OF ITAB : NUMBER OF ALLOCATED REAL*8, ADDRESS OF THE 1ST REAL*8
2013 */
2014 /* , NOCT , VIRTUAL ADDRESS */
2015
2016 /* PP COMMON / CRGEN2 / DTAB */
2017
2018
2019 /* ----------------------------------------------------------------------*
2020 */
2021
2022 *ier = 0;
2023
2024 /* ALLOCATION : FIND A HOLE */
2025
2026 if (*kop == 1) {
2027 *iadr = 0;
2028 if (*noct < 1) {
2029 *ier = 1;
2030 goto L9900;
2031 }
2032 if (ntab >= 40) {
2033 *ier = 2;
2034 goto L9900;
2035 }
2036
2037 i__1 = ntab + 1;
2038 for (i__ = 1; i__ <= i__1; ++i__) {
2039 if (i__ <= 1) {
2040 ipre = 1;
2041 } else {
2042 ipre = itab[((i__ - 1) << 2) - 3] + itab[((i__ - 1) << 2) - 4];
2043 }
2044 if (i__ <= ntab) {
2045 ideb = itab[(i__ << 2) - 3];
2046 } else {
2047 ideb = 32001;
2048 }
2049 if ((ideb - ipre) << 3 >= *noct) {
2050 /* A HOLE WAS FOUND */
2051 i__2 = i__;
2052 for (j = ntab; j >= i__2; --j) {
2053 for (k = 1; k <= 4; ++k) {
2054 itab[k + ((j + 1) << 2) - 5] = itab[k + (j << 2) - 5];
2055 /* L1003: */
2056 }
2057 /* L1002: */
2058 }
2059 ++ntab;
2060 itab[(i__ << 2) - 4] = *noct / 8 + 1;
2061 itab[(i__ << 2) - 3] = ipre;
2062 itab[(i__ << 2) - 2] = *noct;
2063 *iadr = reinterpret_cast<intptr_t> (&dtab[ipre - 1]);
2064 itab[(i__ << 2) - 1] = *iadr;
2065 goto L9900;
2066 }
2067 /* L1001: */
2068 }
2069
2070 /* NO HOLE */
2071
2072 *ier = 3;
2073 goto L9900;
2074
2075 /* ----------------------------------- */
2076 /* DESTRUCTION OF THE ALLOCATION NUM : */
2077
2078 } else {
2079 i__1 = ntab;
2080 for (i__ = 1; i__ <= i__1; ++i__) {
2081 if (*noct != itab[(i__ << 2) - 2]) {
2082 goto L2001;
2083 }
2084 if (*iadr != itab[(i__ << 2) - 1]) {
2085 goto L2001;
2086 }
2087 /* THE ALLOCATION TO BE REMOVED WAS FOUND */
2088 i__2 = ntab;
2089 for (j = i__ + 1; j <= i__2; ++j) {
2090 for (k = 1; k <= 4; ++k) {
2091 itab[k + ((j - 1) << 2) - 5] = itab[k + (j << 2) - 5];
2092 /* L2003: */
2093 }
2094 /* L2002: */
2095 }
2096 --ntab;
2097 goto L9900;
2098 L2001:
2099 ;
2100 }
2101
2102 /* THE ALLOCATION DOES NOT EXIST */
2103
2104 *ier = 4;
2105 /* PP GOTO 9900 */
2106 }
2107
2108 L9900:
2109 return 0;
2110 } /* mcrcomm_ */
2111
2112 //=======================================================================
2113 //function : AdvApp2Var_SysBase::mcrdelt_
2114 //purpose :
2115 //=======================================================================
mcrdelt_(integer * iunit,integer * isize,void * t,intptr_t * iofset,integer * iercod)2116 int AdvApp2Var_SysBase::mcrdelt_(integer *iunit,
2117 integer *isize,
2118 void *t,
2119 intptr_t *iofset,
2120 integer *iercod)
2121
2122 {
2123 integer ibid;
2124 doublereal xbid;
2125 integer noct, iver, ksys, i__, n, nrang,
2126 ibyte, ier;
2127 intptr_t iadfd, iadff, iaddr, loc; /* Les adrresses en long*/
2128 integer kop;
2129
2130 /* ***********************************************************************
2131 */
2132
2133 /* FUNCTION : */
2134 /* ---------- */
2135 /* DESTRUCTION OF A DYNAMIC ALLOCATION */
2136
2137 /* KEYWORDS : */
2138 /* ----------- */
2139 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
2140
2141 /* INPUT ARGUMENTS : */
2142 /* ------------------ */
2143 /* IUNIT : NUMBER OF OCTETS OF THE ALLOCATION UNIT */
2144 /* ISIZE : NUMBER OF UNITS REQUIRED */
2145 /* T : REFERENCE ADDRESS */
2146 /* IOFSET : OFFSET */
2147
2148 /* OUTPUT ARGUMENTS : */
2149 /* ------------------- */
2150 /* IERCOD : ERROR CODE */
2151 /* = 0 : OK */
2152 /* = 1 : PB OF DE-ALLOCATION OF A ZONE ALLOCATED IN COMMON */
2153 /* = 2 : THE SYSTEM REFUSES TO DEMAND DE-ALLOCATION */
2154 /* = 3 : THE ALLOCATION TO BE DESTROYED DOES NOT EXIST. */
2155
2156 /* COMMONS USED : */
2157 /* ---------------- */
2158
2159
2160 /* REFERENCES CALLED : */
2161 /* --------------------- */
2162
2163
2164 /* DESCRIPTION/NOTES/LIMITATIONS : */
2165 /* ----------------------------------- */
2166
2167 /* 1) UTILISATEUR */
2168 /* ----------- */
2169
2170 /* MCRDELT FREES ALLOCATED MEMORY ZONE */
2171 /* BY ROUTINE MCRRQST (OR CRINCR) */
2172
2173 /* THE MEANING OF ARGUMENTS IS THE SAME AS MCRRQST */
2174
2175 /* *** ATTENTION : */
2176 /* ----------- */
2177 /* IERCOD=2 : CASE WHEN THE SYSTEM CANNOT FREE THE ALLOCATED MEMORY, */
2178 /* THE FOLLOWING MESSAGE APPEARS SYSTEMATICALLY ON CONSOLE ALPHA : */
2179 /* "THe system refuseS destruction of memory allocation" */
2180
2181 /* IERCOD=3 CORRESPONDS TO THE CASE WHEN THE ARGUMENTS ARE NOT CORRECT */
2182 /* (THEY DO NOT ALLOW TO RECOGNIZE THE ALLOCATION IN THE TABLE)
2183 */
2184
2185 /* When the allocation is destroyed, the corresponding IOFSET is set to */
2186 /* 2 147 483 647. So, if one gets access to the table via IOFSET, there is */
2187 /* a trap. This allows to check that the freed memory zone is not usede. This verification is */
2188 /* valid only if the same sub-program uses and destroys the allocation. */
2189
2190 /* > */
2191 /* ***********************************************************************
2192 */
2193
2194 /* COMMON OF PARAMETERS */
2195
2196 /* COMMON OF STATISTICS */
2197 /* INCLUDE MCRGENE */
2198
2199 /* ***********************************************************************
2200 */
2201
2202 /* FUNCTION : */
2203 /* ---------- */
2204 /* TABLE OF MANAGEMENT OF DYNAMIC ALLOCATIONS IN MEMORY */
2205
2206 /* KEYWORS : */
2207 /* ----------- */
2208 /* SYSTEM, MEMORY, ALLOCATION */
2209
2210 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2211 /* ----------------------------------- */
2212
2213
2214 /* > */
2215 /* ***********************************************************************
2216 */
2217 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2218 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2219 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2220 /* 2 : UNIT OF ALLOCATION */
2221 /* 3 : NB OF ALLOCATED UNITS */
2222 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2223 /* 5 : IOFSET */
2224 /* 6 : STATIC ALLOCATION NUMBER */
2225 /* 7 : Required allocation size */
2226 /* 8 : address of the beginning of allocation */
2227 /* 9 : Size of the USER ZONE */
2228 /* 10 : ADDRESS of the START FLAG */
2229 /* 11 : ADDRESS of the END FLAG */
2230 /* 12 : Rank of creation of the allocation */
2231
2232 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2233 /* NCORE : NB OF CURRENT ALLOCS */
2234 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2235 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2236
2237
2238
2239 /* ----------------------------------------------------------------------*
2240 */
2241
2242
2243 /* 20-10-86 : BF ; INITIAL VERSION */
2244
2245
2246 /* NRQST : NUMBER OF ALLOCATIONS */
2247 /* NDELT : NUMBER OF LIBERATIONS */
2248 /* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2249 /* MBYTE : MAX NUMBER OF OCTETS */
2250
2251 /* Function Body */
2252 *iercod = 0;
2253
2254 /* SEARCH IN MCRGENE */
2255
2256 n = -1;
2257 loc = reinterpret_cast<intptr_t> (t);
2258
2259 for (i__ = mcrgene_.ncore - 1; i__ >= 0; --i__) {
2260 if (*iunit == mcrgene_.icore[i__].unit && *isize ==
2261 mcrgene_.icore[i__].reqsize && loc == mcrgene_.icore[i__].loc
2262 && *iofset == mcrgene_.icore[i__].offset) {
2263 n = i__;
2264 goto L1100;
2265 }
2266 /* L1001: */
2267 }
2268 L1100:
2269
2270 /* IF THE ALLOCATION DOES NOT EXIST, LEAVE */
2271
2272 if (n < 0) {
2273 goto L9003;
2274 }
2275
2276 /* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */
2277
2278 ksys = mcrgene_.icore[n].alloctype;
2279 ibyte = mcrgene_.icore[n].size;
2280 iaddr = mcrgene_.icore[n].addr;
2281 iadfd = mcrgene_.icore[n].startaddr;
2282 iadff = mcrgene_.icore[n].endaddr;
2283 nrang = mcrgene_.icore[n].rank;
2284
2285 /* Control of flags */
2286
2287 madbtbk_(&iver);
2288 if (iver == 1) {
2289 macrchk_();
2290 }
2291
2292 if (ksys == static_allocation) {
2293 /* DE-ALLOCATION ON COMMON */
2294 kop = 2;
2295 mcrcomm_(&kop, &ibyte, &iaddr, &ier);
2296 if (ier != 0) {
2297 goto L9001;
2298 }
2299 } else {
2300 /* DE-ALLOCATION SYSTEM */
2301 mcrfree_(&ibyte, iaddr, &ier);
2302 if (ier != 0) {
2303 goto L9002;
2304 }
2305 }
2306
2307 /* CALL ALLOWING TO CANCEL AUTOMATIC WATCH BY THE DEBUGGER */
2308
2309 macrclw_(&iadfd, &iadff, &nrang);
2310
2311 /* UPDATE OF STATISTICS */
2312 ++mcrstac_.ndelt[ksys];
2313 mcrstac_.nbyte[ksys] -= mcrgene_.icore[n].unit *
2314 mcrgene_.icore[n].reqsize;
2315
2316 /* REMOVAL OF PARAMETERS IN MCRGENE */
2317 if (n < MAX_ALLOC_NB - 1) {
2318 noct = (mcrgene_.ncore - (n + 1)) * sizeof(mcrgene_.icore[0]);
2319 AdvApp2Var_SysBase::mcrfill_(&noct,
2320 &mcrgene_.icore[n + 1],
2321 &mcrgene_.icore[n]);
2322 }
2323 --mcrgene_.ncore;
2324
2325 /* *** Set to overflow of IOFSET */
2326 {
2327 /* nested scope needed to avoid gcc compilation error crossing
2328 initialization with goto*/
2329 /* assign max positive integer to *iofset */
2330 const size_t shift = sizeof (*iofset) * 8 - 1;
2331 *iofset = (uintptr_t(1) << shift) - 1 /*2147483647 for 32bit*/;
2332 }
2333 goto L9900;
2334
2335 /* ----------------------------------------------------------------------*
2336 */
2337 /* ERROR PROCESSING */
2338
2339 L9001:
2340 /* REFUSE DE-ALLOCATION BY ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
2341 *iercod = 1;
2342 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2343 maostrd_();
2344 goto L9900;
2345
2346 /* REFUSE DE-ALLOCATION BY THE SYSTEM */
2347 L9002:
2348 *iercod = 2;
2349 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2350 macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
2351 maostrd_();
2352 goto L9900;
2353
2354 /* ALLOCATION DOES NOT EXIST */
2355 L9003:
2356 *iercod = 3;
2357 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2358 maostrd_();
2359 goto L9900;
2360
2361 L9900:
2362
2363 return 0 ;
2364
2365 } /* mcrdelt_ */
2366
2367
2368 /*
2369 C*********************************************************************
2370 C
2371 C FUNCTION :
2372 C ----------
2373 C Transfer a memory zone in another by managing intersections
2374 C
2375 C KEYWORDS :
2376 C -----------
2377 C MANIPULATION, MEMORY, TRANSFER, CHARACTER
2378 C
2379 C INPUT ARGUMENTS :
2380 C -----------------
2381 C nb_car : integer*4 number of characters to transfer.
2382 C source : source memory zone.
2383 C
2384 C OUTPUT ARGUMENTS :
2385 C -------------------
2386 C dest : zone memory destination.
2387 C
2388 C COMMONS USED :
2389 C ----------------
2390 C
2391 C REFERENCES CALLED :
2392 C -------------------
2393 C
2394 C DEMSCRIPTION/NOTES/LIMITATIONS :
2395 C -----------------------------------
2396 C Routine portable UNIX (SGI, ULTRIX, BULL)
2397 C
2398
2399 C>
2400 C**********************************************************************
2401 */
2402
2403 //=======================================================================
2404 //function : AdvApp2Var_SysBase::mcrfill_
2405 //purpose :
2406 //=======================================================================
mcrfill_(integer * size,void * tin,void * tout)2407 int AdvApp2Var_SysBase::mcrfill_(integer *size,
2408 void *tin,
2409 void *tout)
2410
2411 {
2412 char *jmin=static_cast<char*> (tin);
2413 char *jmout=static_cast<char*> (tout);
2414 if (mcrfill_ABS(jmout-jmin) >= *size)
2415 memcpy( tout, tin, *size);
2416 else if (tin > tout)
2417 {
2418 integer n = *size;
2419 while (n-- > 0) *jmout++ = *jmin++;
2420 }
2421 else
2422 {
2423 integer n = *size;
2424 jmin+=n;
2425 jmout+=n;
2426 while (n-- > 0) *--jmout = *--jmin;
2427 }
2428 return 0;
2429 }
2430
2431
2432 /*........................................................................*/
2433 /* */
2434 /* FUNCTION : */
2435 /* ---------- */
2436 /* Routines for management of the dynamic memory. */
2437 /* */
2438 /* Routine mcrfree */
2439 /* -------------- */
2440 /* */
2441 /* Desallocation of a memory zone . */
2442 /* */
2443 /* CALL MCRFREE (IBYTE,IADR,IER) */
2444 /* */
2445 /* IBYTE INTEGER*4 : Nb of Octets to free */
2446 /* */
2447 /* IADR POINTEUR : Start Address */
2448 /* */
2449 /* IER INTEGER*4 : Return Code */
2450 /* */
2451 /* */
2452 /*........................................................................*/
2453 /* */
2454
2455 //=======================================================================
2456 //function : mcrfree_
2457 //purpose :
2458 //=======================================================================
mcrfree_(integer *,intptr_t iadr,integer * ier)2459 int mcrfree_(integer *,//ibyte,
2460 intptr_t iadr,
2461 integer *ier)
2462
2463 {
2464 *ier=0;
2465 Standard::Free((void*)iadr);
2466 return 0;
2467 }
2468
2469 /*........................................................................*/
2470 /* */
2471 /* FONCTION : */
2472 /* ---------- */
2473 /* Routines for management of the dynamic memory. */
2474 /* */
2475 /* Routine mcrgetv */
2476 /* -------------- */
2477 /* */
2478 /* Demand of memory allocation. */
2479 /* */
2480 /* CALL MCRGETV(IBYTE,IADR,IER) */
2481 /* */
2482 /* IBYTE (INTEGER*4) Nb of Bytes of allocation required */
2483 /* */
2484 /* IADR (INTEGER*4) : Result. */
2485 /* */
2486 /* IER (INTEGER*4) : Error Code : */
2487 /* */
2488 /* = 0 ==> OK */
2489 /* = 1 ==> Allocation impossible */
2490 /* = -1 ==> Ofset > 2**31 - 1 */
2491 /* */
2492
2493 /* */
2494 /*........................................................................*/
2495
2496 //=======================================================================
2497 //function : mcrgetv_
2498 //purpose :
2499 //=======================================================================
mcrgetv_(integer * sz,intptr_t * iad,integer * ier)2500 int mcrgetv_(integer *sz,
2501 intptr_t *iad,
2502 integer *ier)
2503
2504 {
2505
2506 *ier = 0;
2507 *iad = (intptr_t)Standard::Allocate(*sz);
2508 if ( !*iad ) *ier = 1;
2509 return 0;
2510 }
2511
2512
2513 //=======================================================================
2514 //function : mcrlist_
2515 //purpose :
2516 //=======================================================================
mcrlist_(integer * ier) const2517 int AdvApp2Var_SysBase::mcrlist_(integer *ier) const
2518
2519 {
2520 /* System generated locals */
2521 integer i__1;
2522
2523 /* Builtin functions */
2524
2525 /* Local variables */
2526 char cfmt[1];
2527 doublereal dfmt;
2528 integer ifmt, i__, nufmt, ntotal;
2529 char subrou[7];
2530
2531
2532 /************************************************************************
2533 *******/
2534
2535 /* FUNCTION : */
2536 /* ---------- */
2537 /* PRINT TABLE OF CURRENT DYNAMIC ALLOCATIONS */
2538
2539 /* KEYWORDS : */
2540 /* ----------- */
2541 /* SYSTEM, ALLOCATION, MEMORY, LIST */
2542
2543 /* INPUT ARGUMENTS : */
2544 /* ------------------ */
2545 /* . NONE */
2546
2547 /* OUTPUT ARGUMENTS : */
2548 /* ------------------- */
2549 /* * : */
2550 /* * : */
2551 /* IERCOD : ERROR CODE */
2552
2553 /* IERCOD = 0 : OK */
2554 /* IERCOD > 0 : SERIOUS ERROR */
2555 /* IERCOD < 0 : WARNING */
2556 /* IERCOD = 1 : ERROR DESCRIPTION */
2557 /* IERCOD = 2 : ERROR DESCRIPTION */
2558
2559 /* COMMONS USED : */
2560 /* ---------------- */
2561
2562 /* MCRGENE VFORMT */
2563
2564 /* REFERENCES CALLED : */
2565 /* ---------------------- */
2566
2567 /* Type Name */
2568 /* VFORMA */
2569
2570 /* DESCRIPTION/NOTES/LIMITATIONS : */
2571 /* ----------------------------------- */
2572 /* . NONE */
2573
2574
2575
2576 /* > */
2577 /* ***********************************************************************
2578 */
2579
2580 /* INCLUDE MCRGENE */
2581 /* ***********************************************************************
2582 */
2583
2584 /* FUNCTION : */
2585 /* ---------- */
2586 /* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2587
2588 /* KEYWORDS : */
2589 /* ----------- */
2590 /* SYSTEM, MEMORY, ALLOCATION */
2591
2592 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2593 /* ----------------------------------- */
2594
2595
2596 /* > */
2597 /* ***********************************************************************
2598 */
2599
2600 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2601 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2602 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2603 /* 2 : UNIT OF ALLOCATION */
2604 /* 3 : NB OF ALLOCATED UNITS */
2605 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2606 /* 5 : IOFSET */
2607 /* 6 : STATIC ALLOCATION NUMBER */
2608 /* 7 : Required allocation size */
2609 /* 8 : address of the beginning of allocation */
2610 /* 9 : Size of the USER ZONE */
2611 /* 10 : ADDRESS of the START FLAG */
2612 /* 11 : ADDRESS of the END FLAG */
2613 /* 12 : Rank of creation of the allocation */
2614
2615 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2616 /* NCORE : NB OF CURRENT ALLOCS */
2617 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2618 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2619
2620
2621
2622 /* ----------------------------------------------------------------------*
2623 */
2624
2625
2626 /* ----------------------------------------------------------------------*
2627 */
2628
2629 *ier = 0;
2630 //__s__copy(subrou, "MCRLIST", 7L, 7L);
2631
2632 /* WRITE HEADING */
2633
2634 nufmt = 1;
2635 ifmt = mcrgene_.ncore;
2636 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2637
2638 ntotal = 0;
2639
2640 i__1 = mcrgene_.ncore;
2641 for (i__ = 0; i__ < i__1; ++i__) {
2642 nufmt = 2;
2643 ifmt = mcrgene_.icore[i__].unit * mcrgene_.icore[i__].reqsize
2644 ;
2645 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2646 ntotal += ifmt;
2647 /* L1001: */
2648 }
2649
2650 nufmt = 3;
2651 ifmt = ntotal;
2652 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2653
2654 return 0 ;
2655 } /* mcrlist_ */
2656
2657 //=======================================================================
2658 //function : AdvApp2Var_SysBase::mcrrqst_
2659 //purpose :
2660 //=======================================================================
mcrrqst_(integer * iunit,integer * isize,void * t,intptr_t * iofset,integer * iercod)2661 int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
2662 integer *isize,
2663 void *t,
2664 intptr_t *iofset,
2665 integer *iercod)
2666
2667 {
2668
2669 integer i__1, i__2;
2670
2671 /* Local variables */
2672 doublereal dfmt;
2673 integer ifmt, iver;
2674 char subr[7];
2675 integer ksys , ibyte, irest, ier;
2676 intptr_t iadfd, iadff, iaddr,lofset, loc;
2677 integer izu;
2678
2679
2680 /* **********************************************************************
2681 */
2682
2683 /* FUNCTION : */
2684 /* ---------- */
2685 /* IMPLEMENTATION OF DYNAMIC MEMORY ALLOCATION */
2686
2687 /* KEYWORDS : */
2688 /* ----------- */
2689 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
2690
2691 /* INPUT ARGUMENTS : */
2692 /* ------------------ */
2693 /* IUNIT : NUMBER OF OCTET OF THE UNIT OF ALLOCATION */
2694 /* ISIZE : NUMBER OF UNITS REQUIRED */
2695 /* T : REFERENCE ADDRESS */
2696
2697 /* OUTPUT ARGUMENTS : */
2698 /* ------------------- */
2699 /* IOFSET : OFFSET */
2700 /* IERCOD : ERROR CODE, */
2701 /* = 0 : OK */
2702 /* = 1 : MAX NB OF ALLOCS REACHED */
2703 /* = 2 : ARGUMENTS INCORRECT */
2704 /* = 3 : REFUSED DYNAMIC ALLOCATION */
2705
2706 /* COMMONS USED : */
2707 /* ---------------- */
2708 /* MCRGENE, MCRSTAC */
2709
2710 /* REFERENCES CALLED : */
2711 /* ----------------------- */
2712 /* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
2713
2714 /* DESCRIPTION/NOTES/LIMITATIONS : */
2715 /* ----------------------------------- */
2716
2717 /* 1) USER */
2718 /* -------------- */
2719
2720 /* T IS THE ADDRESS OF A TABLE, IOFSET REPRESENTS THE DEPLACEMENT IN */
2721 /* UNITS OF IUNIT OCTETS BETWEEN THE ALLOCATED ZONE AND TABLE T */
2722 /* IERCOD=0 SIGNALS THAT THE ALLOCATION WORKS WELL, ANY OTHER */
2723 /* VALUE INDICATES A BUG. */
2724
2725 /* EXAMPLE : */
2726 /* LET THE DECLARATION REAL*4 T(1), SO IUNIT=4 . */
2727 /* CALL TO MCRRQST PORODUCES DYNAMIC ALLOCATION */
2728 /* AND GIVES VALUE TO VARIABLE IOFSET, */
2729 /* IF IT IS REQUIRED TO WRITE 1. IN THE 5TH ZONE REAL*4 */
2730 /* ALLOCATED IN THIS WAY, MAKE: */
2731 /* T(5+IOFSET)=1. */
2732
2733 /* CASE OF ERRORS : */
2734 /* --------------- */
2735
2736 /* IERCOD=1 : MAX NB OF ALLOCATION REACHED (ACTUALLY 200) */
2737 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2738 /* "The max number of memory allocation is reached : ,N" */
2739
2740 /* IERCOD=2 : ARGUMENT IUNIT INCORRECT AS IT IS DIFFERENT FROM 1,2,4 OR 8 */
2741 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2742 /* "Unit OF allocation invalid : ,IUNIT" */
2743
2744 /* IERCOD=3 : REFUSED DYNAMIC ALLOCATION (MORE PLACE IN MEMORY) */
2745 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2746 /* "The system refuses dynamic allocation of memory of N octets"
2747 */
2748 /* with completev display of all allocations carried out till now */
2749
2750
2751 /* 2) DESIGNER */
2752 /* -------------- */
2753
2754 /* MCRRQST MAKES DYNAMIC ALLOCATION OF VIRTUAL MEMORY ON THE BASE */
2755 /* OF ENTITIES OF 8 OCTETS (QUADWORDS), WHILE THE ALLOCATION IS REQUIRED BY */
2756 /* UNITS OF IUNIT OCTETS (1,2,4,8). */
2757
2758 /* THE REQUIRED QUANTITY IS IUNIT*ISIZE OCTETS, THIS VALUE IS ROUNDED */
2759 /* SO THAT THE ALLOCATION WAS AN INTEGER NUMBER OF QUADWORDS. */
2760
2761
2762
2763 /* > */
2764 /* ***********************************************************************
2765 */
2766
2767 /* COMMON OF PARAMETRES */
2768 /* COMMON OF INFORMATION ON STATISTICS */
2769 /* INCLUDE MCRGENE */
2770
2771 /* ***********************************************************************
2772 */
2773 /* FUNCTION : */
2774 /* ---------- */
2775 /* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2776
2777 /* KEYWORDS : */
2778 /* ----------- */
2779 /* SYSTEM, MEMORY, ALLOCATION */
2780
2781 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2782 /* ----------------------------------- */
2783
2784
2785 /* > */
2786 /* ***********************************************************************
2787 */
2788
2789 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2790 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2791 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2792 /* 2 : UNIT OF ALLOCATION */
2793 /* 3 : NB OF ALLOCATED UNITS */
2794 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2795 /* 5 : IOFSET */
2796 /* 6 : STATIC ALLOCATION NUMBER */
2797 /* 7 : Required allocation size */
2798 /* 8 : address of the beginning of allocation */
2799 /* 9 : Size of the USER ZONE */
2800 /* 10 : ADDRESS of the START FLAG */
2801 /* 11 : ADDRESS of the END FLAG */
2802 /* 12 : Rank of creation of the allocation */
2803
2804 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2805 /* NCORE : NB OF CURRENT ALLOCS */
2806 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2807 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2808
2809
2810
2811
2812 /* ----------------------------------------------------------------------*
2813 */
2814 /* 20-10-86 : BF ; INITIAL VERSION */
2815
2816
2817 /* NRQST : NUMBER OF ALLOCATIONS */
2818 /* NDELT : NUMBER OF LIBERATIONS */
2819 /* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2820 /* MBYTE : MAX NUMBER OF OCTETS */
2821
2822
2823 /* ----------------------------------------------------------------------*
2824 */
2825
2826 /* Function Body */
2827 *iercod = 0;
2828
2829 if (mcrgene_.ncore >= MAX_ALLOC_NB) {
2830 goto L9001;
2831 }
2832 if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
2833 goto L9002;
2834 }
2835
2836 /* Calculate the size required by the user */
2837 ibyte = *iunit * *isize;
2838
2839 /* Find the type of version (Phase of Production or Version Client) */
2840 madbtbk_(&iver);
2841
2842 /* Control allocated size in Production phase */
2843
2844 if (iver == 1) {
2845
2846 if (ibyte == 0) {
2847 //do__lio(&c__9, &c__1, "Require zero allocation", 26L);
2848 maostrb_();
2849 } else if (ibyte >= 4096000) {
2850 //do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L);
2851 //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
2852 maostrb_();
2853 }
2854
2855 }
2856
2857 /* CALCULATE THE SIZE OF THE USER ZONE (IZU) */
2858 /* . add size required by the user (IBYTE) */
2859 /* . add delta for alinement with the base */
2860 /* . round to multiple of 8 above */
2861
2862 loc = reinterpret_cast<intptr_t> (t);
2863 izu = ibyte + loc % *iunit;
2864 irest = izu % 8;
2865 if (irest != 0) {
2866 izu = izu + 8 - irest;
2867 }
2868
2869 /* CALCULATE THE SIZE REQUIRED FROM THE PRIMITIVE OF ALLOC */
2870 /* . add size of the user zone */
2871 /* . add 8 for alinement of start address of */
2872 /* allocation on multiple of 8 so that to be able to */
2873 /* set flags with Double Precision without other pb than alignement */
2874 /* . add 16 octets for two flags */
2875
2876 ibyte = izu + 24;
2877
2878 /* DEMAND OF ALLOCATION */
2879
2880 /* L1001: */
2881 /* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
2882 /* ALLOCATION SUR TABLE */
2883 /* KSYS = 1 */
2884 /* KOP = 1 */
2885 /* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
2886 /* IF ( IER .NE. 0 ) THEN */
2887 /* ISYST=1 */
2888 /* GOTO 1001 */
2889 /* ENDIF */
2890 /* ELSE */
2891 /* ALLOCATION SYSTEME */
2892 ksys = heap_allocation;
2893 mcrgetv_(&ibyte, &iaddr, &ier);
2894 if (ier != 0) {
2895 goto L9003;
2896 }
2897 /* ENDIF */
2898
2899 /* CALCULATE THE ADDRESSES OF FLAGS */
2900
2901 iadfd = iaddr + 8 - iaddr % 8;
2902 iadff = iadfd + 8 + izu;
2903
2904 /* CALCULATE USER OFFSET : */
2905 /* . difference between the user start address and the */
2906 /* base address */
2907 /* . converts this difference in the user unit */
2908
2909 lofset = iadfd + 8 + loc % *iunit - loc;
2910 *iofset = lofset / *iunit;
2911
2912 /* If phase of production control flags */
2913 if (iver == 1) {
2914 macrchk_();
2915 }
2916
2917 /* SET FLAGS */
2918 /* . the first flag is set by IADFD and the second by IADFF */
2919 /* . if phase of production, set to overflow the ZU */
2920 macrgfl_(&iadfd, &iadff, &iver, &izu);
2921
2922 /* RANGING OF PARAMETERS IN MCRGENE */
2923
2924 mcrgene_.icore[mcrgene_.ncore].prot = mcrgene_.lprot;
2925 mcrgene_.icore[mcrgene_.ncore].unit = (unsigned char)(*iunit);
2926 mcrgene_.icore[mcrgene_.ncore].reqsize = *isize;
2927 mcrgene_.icore[mcrgene_.ncore].loc = loc;
2928 mcrgene_.icore[mcrgene_.ncore].offset = *iofset;
2929 mcrgene_.icore[mcrgene_.ncore].alloctype = (unsigned char)ksys;
2930 mcrgene_.icore[mcrgene_.ncore].size = ibyte;
2931 mcrgene_.icore[mcrgene_.ncore].addr = iaddr;
2932 mcrgene_.icore[mcrgene_.ncore].userzone = mcrgene_.ncore;
2933 mcrgene_.icore[mcrgene_.ncore].startaddr = iadfd;
2934 mcrgene_.icore[mcrgene_.ncore].endaddr = iadff;
2935 mcrgene_.icore[mcrgene_.ncore].rank = mcrgene_.ncore + 1;
2936 ++mcrgene_.ncore;
2937
2938 mcrgene_.lprot = 0;
2939
2940 /* CALL ALLOWING AUTOIMPLEMENTATION OF THE SET WATCH BY THE DEBUGGER */
2941
2942 macrstw_(&iadfd, &iadff, &mcrgene_.ncore);
2943
2944 /* STATISTICS */
2945
2946 ++mcrstac_.nrqst[ksys];
2947 mcrstac_.nbyte[ksys] += mcrgene_.icore[mcrgene_.ncore - 1].unit *
2948 mcrgene_.icore[mcrgene_.ncore - 1].reqsize;
2949 /* Computing MAX */
2950 i__1 = mcrstac_.mbyte[ksys], i__2 = mcrstac_.nbyte[ksys];
2951 mcrstac_.mbyte[ksys] = advapp_max(i__1,i__2);
2952
2953 goto L9900;
2954
2955 /* ----------------------------------------------------------------------*
2956 */
2957 /* ERROR PROCESSING */
2958
2959 /* MAX NB OF ALLOC REACHED : */
2960 L9001:
2961 *iercod = 1;
2962 ifmt = MAX_ALLOC_NB;
2963 //__s__copy(subr, "MCRRQST", 7L, 7L);
2964 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
2965 maostrd_();
2966 goto L9900;
2967
2968 /* INCORRECT ARGUMENTS */
2969 L9002:
2970 *iercod = 2;
2971 ifmt = *iunit;
2972 //__s__copy(subr, "MCRRQST", 7L, 7L);
2973 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
2974 goto L9900;
2975
2976 /* SYSTEM REFUSES ALLOCATION */
2977 L9003:
2978 *iercod = 3;
2979 ifmt = ibyte;
2980 //__s__copy(subr, "MCRRQST", 7L, 7L);
2981 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
2982 maostrd_();
2983 mcrlist_(&ier);
2984 goto L9900;
2985
2986 /* ----------------------------------------------------------------------*
2987 */
2988
2989 L9900:
2990 mcrgene_.lprot = 0;
2991 return 0 ;
2992 } /* mcrrqst_ */
2993
2994 //=======================================================================
2995 //function : AdvApp2Var_SysBase::mgenmsg_
2996 //purpose :
2997 //=======================================================================
mgenmsg_(const char *,ftnlen)2998 int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
2999 ftnlen )//nomprg_len)
3000
3001 {
3002 return 0;
3003 } /* mgenmsg_ */
3004
3005 //=======================================================================
3006 //function : AdvApp2Var_SysBase::mgsomsg_
3007 //purpose :
3008 //=======================================================================
mgsomsg_(const char *,ftnlen)3009 int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
3010 ftnlen )//nomprg_len)
3011
3012 {
3013 return 0;
3014 } /* mgsomsg_ */
3015
3016
3017 /*
3018 C
3019 C*****************************************************************************
3020 C
3021 C FUNCTION : CALL MIRAZ(LENGTH,ITAB)
3022 C ----------
3023 C
3024 C RESET TO ZERO A TABLE OF LOGIC OR INTEGER.
3025 C
3026 C KEYWORDS :
3027 C -----------
3028 C RAZ INTEGER
3029 C
3030 C INPUT ARGUMENTS :
3031 C ------------------
3032 C LENGTH : NUMBER OF OCTETS TO TRANSFER
3033 C ITAB : NAME OF THE TABLE
3034 C
3035 C OUTPUT ARGUMENTS :
3036 C -------------------
3037 C ITAB : NAME OF THE TABLE SET TO ZERO
3038 C
3039 C COMMONS USED :
3040 C ----------------
3041 C
3042 C REFERENCES CALLED :
3043 C ---------------------
3044 C
3045 C DEMSCRIPTION/NOTES/LIMITATIONS :
3046 C -----------------------------------
3047 C
3048 C Portable VAX-SGI
3049
3050 C>
3051 C***********************************************************************
3052 */
3053 //=======================================================================
3054 //function : AdvApp2Var_SysBase::miraz_
3055 //purpose :
3056 //=======================================================================
miraz_(integer * taille,void * adt)3057 void AdvApp2Var_SysBase::miraz_(integer *taille,
3058 void *adt)
3059
3060 {
3061 memset(adt , '\0' , *taille) ;
3062 }
3063 //=======================================================================
3064 //function : AdvApp2Var_SysBase::mnfndeb_
3065 //purpose :
3066 //=======================================================================
mnfndeb_()3067 integer AdvApp2Var_SysBase::mnfndeb_()
3068 {
3069 integer ret_val;
3070 ret_val = 0;
3071 return ret_val;
3072 } /* mnfndeb_ */
3073
3074 //=======================================================================
3075 //function : AdvApp2Var_SysBase::msifill_
3076 //purpose :
3077 //=======================================================================
msifill_(integer * nbintg,integer * ivecin,integer * ivecou)3078 int AdvApp2Var_SysBase::msifill_(integer *nbintg,
3079 integer *ivecin,
3080 integer *ivecou)
3081 {
3082 integer nocte;
3083
3084 /* ***********************************************************************
3085 */
3086
3087 /* FUNCTION : */
3088 /* ---------- */
3089 /* transfer Integer from one zone to another */
3090
3091 /* KEYWORDS : */
3092 /* ----------- */
3093 /* TRANSFER , INTEGER , MEMORY */
3094
3095 /* INPUT ARGUMENTS : */
3096 /* ------------------ */
3097 /* NBINTG : Nb of integers */
3098 /* IVECIN : Input vector */
3099
3100 /* OUTPUT ARGUMENTS : */
3101 /* ------------------- */
3102 /* IVECOU : Output vector */
3103
3104 /* COMMONS USED : */
3105 /* ---------------- */
3106
3107 /* REFERENCES CALLED : */
3108 /* --------------------- */
3109
3110 /* DESCRIPTION/NOTES/LIMITATIONS : */
3111 /* ----------------------------------- */
3112
3113 /* > */
3114 /* ***********************************************************************
3115 */
3116
3117 /* ___ NOCTE : Number of octets to transfer */
3118
3119 /* Parameter adjustments */
3120 --ivecou;
3121 --ivecin;
3122
3123 /* Function Body */
3124 nocte = *nbintg * sizeof(integer);
3125 AdvApp2Var_SysBase::mcrfill_(&nocte, &ivecin[1], &ivecou[1]);
3126 return 0 ;
3127 } /* msifill_ */
3128
3129 //=======================================================================
3130 //function : AdvApp2Var_SysBase::msrfill_
3131 //purpose :
3132 //=======================================================================
msrfill_(integer * nbreel,doublereal * vecent,doublereal * vecsor)3133 int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
3134 doublereal *vecent,
3135 doublereal * vecsor)
3136 {
3137 integer nocte;
3138
3139
3140 /* ***********************************************************************
3141 */
3142
3143 /* FONCTION : */
3144 /* ---------- */
3145 /* Transfer real from one zone to another */
3146
3147 /* KEYWORDS : */
3148 /* ----------- */
3149 /* TRANSFER , REAL , MEMORY */
3150
3151 /* INPUT ARGUMENTS : */
3152 /* ----------------- */
3153 /* NBREEL : Number of reals */
3154 /* VECENT : Input vector */
3155
3156 /* OUTPUT ARGUMENTS : */
3157 /* ------------------- */
3158 /* VECSOR : Output vector */
3159
3160 /* COMMONS USED : */
3161 /* ---------------- */
3162
3163 /* REFERENCES CALLED : */
3164 /* ----------------------- */
3165
3166 /* DESCRIPTION/NOTES/LIMITATIONS : */
3167 /* ----------------------------------- */
3168
3169 /* > */
3170 /* ***********************************************************************
3171 */
3172
3173 /* ___ NOCTE : Nb of octets to transfer */
3174
3175 /* Parameter adjustments */
3176 --vecsor;
3177 --vecent;
3178
3179 /* Function Body */
3180 nocte = *nbreel * sizeof (doublereal);
3181 AdvApp2Var_SysBase::mcrfill_(&nocte, &vecent[1], &vecsor[1]);
3182 return 0 ;
3183 } /* msrfill_ */
3184
3185 //=======================================================================
3186 //function : AdvApp2Var_SysBase::mswrdbg_
3187 //purpose :
3188 //=======================================================================
mswrdbg_(const char *,ftnlen)3189 int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
3190 ftnlen )//ctexte_len)
3191
3192 {
3193
3194 /* ***********************************************************************
3195 */
3196
3197 /* FUNCTION : */
3198 /* ---------- */
3199 /* Write message on console alpha if IBB>0 */
3200
3201 /* KEYWORDS : */
3202 /* ----------- */
3203 /* MESSAGE, DEBUG */
3204
3205 /* INPUT ARGUMENTS : */
3206 /* ----------------- */
3207 /* CTEXTE : Text to be written */
3208
3209 /* OUTPUT ARGUMENTS : */
3210 /* ------------------- */
3211 /* None */
3212
3213 /* COMMONS USED : */
3214 /* ---------------- */
3215
3216 /* REFERENCES CALLED : */
3217 /* ----------------------- */
3218
3219 /* DESCRIPTION/NOTES/LIMITATIONS : */
3220 /* ----------------------------------- */
3221
3222
3223 /* > */
3224 /* ***********************************************************************
3225 */
3226 /* DECLARATIONS */
3227 /* ***********************************************************************
3228 */
3229
3230
3231 /* ***********************************************************************
3232 */
3233 /* PROCESSING */
3234 /* ***********************************************************************
3235 */
3236
3237 if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
3238 //do__lio(&c__9, &c__1, "Dbg ", 4L);
3239 //do__lio(&c__9, &c__1, ctexte, ctexte_len);
3240 }
3241 return 0 ;
3242 } /* mswrdbg_ */
3243
3244
3245
__i__len()3246 int __i__len()
3247 {
3248 return 0;
3249 }
3250
__s__cmp()3251 int __s__cmp()
3252 {
3253 return 0;
3254 }
3255
3256 //=======================================================================
3257 //function : do__fio
3258 //purpose :
3259 //=======================================================================
do__fio()3260 int AdvApp2Var_SysBase::do__fio()
3261 {
3262 return 0;
3263 }
3264 //=======================================================================
3265 //function : do__lio
3266 //purpose :
3267 //=======================================================================
do__lio()3268 int AdvApp2Var_SysBase::do__lio ()
3269 {
3270 return 0;
3271 }
3272
3273 /*
3274 C*****************************************************************************
3275 C
3276 C FUNCTION : CALL MVRIRAZ(NBELT,DTAB)
3277 C ----------
3278 C Reset to zero a table with DOUBLE PRECISION
3279 C
3280 C KEYWORDS :
3281 C -----------
3282 C MVRMIRAZ DOUBLE
3283 C
3284 C INPUT ARGUMENTS :
3285 C ------------------
3286 C NBELT : Number of elements of the table
3287 C DTAB : Table to initializer to zero
3288 C
3289 C OUTPUT ARGUMENTS :
3290 C --------------------
3291 C DTAB : Table reset to zero
3292 C
3293 C COMMONS USED :
3294 C ----------------
3295 C
3296 C REFERENCES CALLED :
3297 C -----------------------
3298 C
3299 C DEMSCRIPTION/NOTES/LIMITATIONS :
3300 C -----------------------------------
3301 C
3302 C
3303 C>
3304 C***********************************************************************
3305 */
3306 //=======================================================================
3307 //function : AdvApp2Var_SysBase::mvriraz_
3308 //purpose :
3309 //=======================================================================
mvriraz_(integer * taille,void * adt)3310 void AdvApp2Var_SysBase::mvriraz_(integer *taille,
3311 void *adt)
3312
3313 {
3314 integer offset;
3315 offset = *taille * 8 ;
3316 /* printf(" adt %d long %d\n",adt,offset); */
3317 memset(adt , '\0' , offset) ;
3318 }
3319