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