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