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