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