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