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