projects / occt.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
0023952: Improving thread-safety of intersections, approximations and other modeling...
[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
1ef32e96 19#include <assert.h>
7fd59977 20#include <math.h>
21#include <stdlib.h>
22#include <string.h>
23#include <AdvApp2Var_Data_f2c.hxx>
24#include <AdvApp2Var_SysBase.hxx>
7fd59977 25#include <AdvApp2Var_Data.hxx>
fadcea2c 26#include <Standard.hxx>
7fd59977 27
28
29static
30int __i__len();
31
32static
33int __s__cmp();
34
35static
36int macrbrk_();
37
7fd59977 38static
fadcea2c
RL		 39int macrclw_(intptr_t *iadfld,
40 intptr_t *iadflf,
7fd59977 41 integer *nalloc);
42static
fadcea2c
RL		 43int macrerr_(intptr_t *iad,
44 intptr_t *nalloc);
45static
46int macrgfl_(intptr_t *iadfld,
47 intptr_t *iadflf,
7fd59977 48 integer *iphase,
49 integer *iznuti);
50static
51int macrmsg_(const char *crout,
52 integer *num,
53 integer *it,
54 doublereal *xt,
55 const char *ct,
56 ftnlen crout_len,
57 ftnlen ct_len);
58
59static
fadcea2c
RL		 60int macrstw_(intptr_t *iadfld,
61 intptr_t *iadflf,
7fd59977 62 integer *nalloc);
63
64static
65int madbtbk_(integer *indice);
66
67static
68int magtlog_(const char *cnmlog,
69 const char *chaine,
70 integer *long__,
71 integer *iercod,
72 ftnlen cnmlog_len,
73 ftnlen chaine_len);
74
75
76static
77int mamdlng_(char *cmdlng,
78 ftnlen cmdlng_len);
79
80static
81int maostrb_();
82
83static
84int maostrd_();
85
86static
87int maoverf_(integer *nbentr,
88 doublereal *dtable);
89
90static
91int matrlog_(const char *cnmlog,
92 const char *chaine,
93 integer *length,
94 integer *iercod,
95 ftnlen cnmlog_len,
96 ftnlen chaine_len);
97
98static
99int matrsym_(const char *cnmsym,
100 const char *chaine,
101 integer *length,
102 integer *iercod,
103 ftnlen cnmsym_len,
104 ftnlen chaine_len);
105
106static
107int mcrcomm_(integer *kop,
108 integer *noct,
fadcea2c 109 intptr_t *iadr,
7fd59977 110 integer *ier);
111
112static
113int mcrfree_(integer *ibyte,
fadcea2c 114 void* *iadr,
7fd59977 115 integer *ier);
116
117static
118int mcrgetv_(integer *sz,
fadcea2c 119 void* *iad,
7fd59977 120 integer *ier);
121
7fd59977 122static
fadcea2c
RL		 123int mcrlocv_(void* t,
124 intptr_t *l);
7fd59977 125
126
7fd59977 127static struct {
128 integer lec, imp, keyb, mae, jscrn, itblt, ibb;
129} mblank__;
130
131#define mcrfill_ABS(a) (((a)<0)?(-(a)):(a))
132
133
1ef32e96
RL		 134//=======================================================================
135//function : AdvApp2Var_SysBase
136//purpose :
137//=======================================================================
138AdvApp2Var_SysBase::AdvApp2Var_SysBase()
139{
140 mainial_();
141 memset (&mcrstac_, 0, sizeof (mcrstac_));
142}
143
144//=======================================================================
145//function : ~AdvApp2Var_SysBase
146//purpose :
147//=======================================================================
148AdvApp2Var_SysBase::~AdvApp2Var_SysBase()
149{
150 assert (mcrgene_.ncore == 0); //otherwise memory leaking
151}
152
7fd59977 153//=======================================================================
154//function : macinit_
155//purpose :
156//=======================================================================
157int AdvApp2Var_SysBase::macinit_(integer *imode,
158 integer *ival)
159
160{
161
162 /* Fortran I/O blocks */
1ef32e96 163 cilist io______1 = { 0, 0, 0, (char*) "(' --- Debug-mode : ',I10,' ---')", 0 };
7fd59977 164
165 /* ************************************************************************/
0d969553 166 /* FUNCTION : */
7fd59977 167 /* ---------- */
0d969553 168 /* INITIALIZATION OF READING WRITING UNITS AND 'IBB' */
7fd59977 169
0d969553 170 /* KEYWORDS : */
7fd59977 171 /* ----------- */
0d969553 172 /* MANAGEMENT, CONFIGURATION, UNITS, INITIALIZATION */
7fd59977 173
0d969553 174 /* INPUT ARGUMENTS : */
7fd59977 175 /* -------------------- */
0d969553
Y		 176 /* IMODE : MODE of INITIALIZATION :
177 0= DEFAULT, IMP IS 6, IBB 0 and LEC 5 */
178 /* 1= FORCE VALUE OF IMP */
179 /* 2= FORCE VALUE OF IBB */
180 /* 3= FORCE VALUE OF LEC */
181
182 /* ARGUMENT USED ONLY WHEN IMODE IS 1 OR 2 : */
183 /* IVAL : VALUE OF IMP WHEN IMODE IS 1 */
184 /* VALUE OF IBB WHEN IMODE IS 2 */
185 /* VALUE OF LEC WHEN IMODE IS 3 */
186 /* THERE IS NO CONTROL OF VALIDITY OF VALUE OF IVAL . */
187
188 /* OUTPUT ARGUMENTS : */
189 /* -------------------- */
190 /* NONE */
191
192 /* COMMONS USED : */
193 /* -------------- */
194 /* REFERENCES CALLED : */
195 /* ------------------- */
196 /* DESCRIPTION/NOTES/LIMITATIONS : */
197 /* ------------------------------- */
198
199 /* THIS IS ONLY INITIALIZATION OF THE COMMON BLANK FOR ALL */
200 /* MODULES THAT A PRIORI DO NOT NEED TO KNOW THE COMMONS OF T . */
201 /* WHEN A MODIFICATION OF IBB IS REQUIRED (IMODE=2) AN INFO MESSAGE */
202 /* IS SUBMITTED ON IMP, WITH THE NEW VALUE OF IBB. */
203
204 /* IBB : MODE DEBUG OF STRIM T : RULES OF USE : */
205 /* 0 RESTRAINED VERSION */
206 /* >0 THE GREATER IS IBB THE MORE COMMENTS THE VERSION HAS. */
207 /* FOR EXAMPLE FOR IBB=1 THE ROUTINES CALLED */
208 /* INFORM ON IMP ('INPUT IN TOTO', */
209 /* AND 'OUTPUT FROM TOTO'), AND THE ROUTINES THAT RETURN */
210 /* NON NULL ERROR CODE INFORM IT AS WELL. */
211 /* (BUT IT IS NOT TRUE FOR ALL ROUTINES OF T) */
7fd59977 212 /* > */
213 /* ***********************************************************************
214 */
215
216 if (*imode == 0) {
217 mblank__.imp = 6;
218 mblank__.ibb = 0;
219 mblank__.lec = 5;
220 } else if (*imode == 1) {
221 mblank__.imp = *ival;
222 } else if (*imode == 2) {
223 mblank__.ibb = *ival;
224 io______1.ciunit = mblank__.imp;
225 /*
226 s__wsfe(&io______1);
227 */
228 /*
229 do__fio(&c____1, (char *)&mblank__.ibb, (ftnlen)sizeof(integer));
230 */
231 AdvApp2Var_SysBase::e__wsfe();
232 } else if (*imode == 3) {
233 mblank__.lec = *ival;
234 }
235
236 /* ----------------------------------------------------------------------*
237 */
238
239 return 0;
240} /* macinit__ */
241
242//=======================================================================
243//function : macrai4_
244//purpose :
245//=======================================================================
246int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
247 integer *maxelm,
248 integer *itablo,
fadcea2c 249 intptr_t *iofset,
7fd59977 250 integer *iercod)
251
252{
253
254 /* ***********************************************************************
255 */
256
0d969553 257 /* FUNCTION : */
7fd59977 258 /* ---------- */
0d969553 259 /* Require dynamic allocation of type INTEGER */
7fd59977 260
0d969553
Y		 261 /* KEYWORDS : */
262 /* ---------- */
263 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
264
265 /* INPUT ARGUMENTS : */
266 /* ----------------- */
267 /* NBELEM : Number of required units */
268 /* MAXELM : Max number of units available in ITABLO */
269 /* ITABLO : Reference Address of the rented zone */
270
271 /* OUTPUT ARGUMENTS : */
272 /* ------------------- */
273 /* IOFSET : Offset */
274 /* IERCOD : Error code */
7fd59977 275 /* = 0 : OK */
0d969553
Y		 276 /* = 1 : Max nb of allocations attained */
277 /* = 2 : Incorrect arguments */
278 /* = 3 : Refused dynamic allocation */
7fd59977 279
0d969553 280 /* COMMONS USED : */
7fd59977 281 /* ------------------ */
282
0d969553 283 /* REFERENCES CALLED : */
7fd59977 284 /* --------------------- */
285 /* MCRRQST */
286
0d969553 287 /* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 288 /* ----------------------------------- */
0d969553 289 /* (Cf description in the heading of MCRRQST) */
7fd59977 290
0d969553
Y		 291 /* Table ITABLO should be dimensioned to MAXELM by the caller. */
292 /* If the request is lower or equal to MAXELM, IOFSET becomes = 0. */
293 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
294 /* > */
7fd59977 295 /* ***********************************************************************
296 */
297
298 integer iunit;
7fd59977 299
300
301 iunit = sizeof(integer);
302 /* Function Body */
303 if (*nbelem > *maxelm) {
1ef32e96 304 /*AdvApp2Var_SysBase::*/mcrrqst_(&iunit, nbelem, itablo, iofset, iercod);
7fd59977 305 } else {
306 *iercod = 0;
307 *iofset = 0;
308 }
309 return 0 ;
310} /* macrai4_ */
311
312//=======================================================================
313//function : AdvApp2Var_SysBase::macrar8_
314//purpose :
315//=======================================================================
316int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
317 integer *maxelm,
318 doublereal *xtablo,
fadcea2c 319 intptr_t *iofset,
7fd59977 320 integer *iercod)
321
322{
1ef32e96 323 integer c__8 = 8;
7fd59977 324
325 /* ***********************************************************************
326 */
327
0d969553 328 /* FUNCTION : */
7fd59977 329 /* ---------- */
0d969553 330 /* Demand of dynamic allocation of type DOUBLE PRECISION */
7fd59977 331
0d969553 332 /* KEYWORDS : */
7fd59977 333 /* ----------- */
0d969553 334 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
7fd59977 335
0d969553
Y		 336 /* INPUT ARGUMENTS : */
337 /* ------------------ */
338 /* NBELEM : Nb of units required */
339 /* MAXELM : Max Nb of units available in XTABLO */
340 /* XTABLO : Reference address of the rented zone */
7fd59977 341
0d969553
Y		 342 /* OUTPUT ARGUMENTS : */
343 /* ------------------ */
344 /* IOFSET : Offset */
345 /* IERCOD : Error code */
7fd59977 346 /* = 0 : OK */
0d969553
Y		 347 /* = 1 : Max Nb of allocations reached */
348 /* = 2 : Arguments incorrect */
349 /* = 3 : Refuse of dynamic allocation */
7fd59977 350
0d969553 351 /* COMMONS USED : */
7fd59977 352 /* ------------------ */
353
0d969553 354 /* REFERENCES CALLED : */
7fd59977 355 /* --------------------- */
356 /* MCRRQST */
357
0d969553 358 /* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 359 /* ----------------------------------- */
0d969553 360 /* (Cf description in the heading of MCRRQST) */
7fd59977 361
0d969553
Y		 362 /* Table XTABLO should be dimensioned to MAXELM by the caller. */
363 /* If the request is less or equal to MAXELM, IOFSET becomes = 0. */
364 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
7fd59977 365
7fd59977 366 /* > */
367 /* ***********************************************************************
368 */
369
370
7fd59977 371 /* Function Body */
372 if (*nbelem > *maxelm) {
1ef32e96 373 /*AdvApp2Var_SysBase::*/mcrrqst_(&c__8, nbelem, xtablo, iofset, iercod);
7fd59977 374 } else {
375 *iercod = 0;
376 *iofset = 0;
377 }
378 return 0 ;
379} /* macrar8_ */
380
381//=======================================================================
382//function : macrbrk_
383//purpose :
384//=======================================================================
385int macrbrk_()
386{
387 return 0 ;
388} /* macrbrk_ */
389
390//=======================================================================
391//function : macrchk_
392//purpose :
393//=======================================================================
1ef32e96 394int AdvApp2Var_SysBase::macrchk_()
7fd59977 395{
396 /* System generated locals */
397 integer i__1;
398
399 /* Local variables */
1ef32e96
RL		 400 integer i__, j;
401 intptr_t ioff;
402 doublereal* t = 0;
403 intptr_t loc;
7fd59977 404
405/* ***********************************************************************
406 */
407
0d969553 408/* FUNCTION : */
7fd59977 409/* ---------- */
0d969553 410/* CONTROL OF EXCESSES OF ALLOCATED MEMORY ZONE */
7fd59977 411
0d969553 412/* KEYWORDS : */
7fd59977 413/* ----------- */
0d969553 414/* SYSTEM, ALLOCATION, MEMORY, CONTROL, EXCESS */
7fd59977 415
0d969553
Y		 416/* INPUT ARGUMENTS : */
417/* ----------------- */
418/* NONE */
7fd59977 419
0d969553
Y		 420/* OUTPUT ARGUMENTS : */
421/* ------------------- */
422/* NONE */
7fd59977 423
0d969553 424/* COMMONS USED : */
7fd59977 425/* ------------------ */
426/* MCRGENE */
427
0d969553 428/* REFERENCES CALLED : */
7fd59977 429/* --------------------- */
430/* MACRERR, MAOSTRD */
431
0d969553 432/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 433/* ----------------------------------- */
434
7fd59977 435/* > */
436/* ***********************************************************************
437 */
438
439/* ***********************************************************************
440 */
441
442/* FONCTION : */
443/* ---------- */
0d969553 444/* TABLE OF MANAGEMENT OF DYNAMIC MEMOTY ALLOCATIONS */
7fd59977 445
0d969553 446/* KEYWORDS : */
7fd59977 447/* ----------- */
0d969553 448/* SYSTEM, MEMORY, ALLOCATION */
7fd59977 449
0d969553 450/* DEMSCRIPTION/NOTES/LIMITATIONS : */
7fd59977 451/* ----------------------------------- */
452
0d969553 453
7fd59977 454/* > */
455/* ***********************************************************************
456 */
457
0d969553
Y		 458/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
459/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
460/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
461/* 2 : UNIT OF ALLOCATION */
462/* 3 : NB OF ALLOCATED UNITS */
463/* 4 : REFERENCE ADDRESS OF THE TABLE */
7fd59977 464/* 5 : IOFSET */
0d969553
Y		 465/* 6 : STATIC ALLOCATION NUMBER */
466/* 7 : Required allocation size */
467/* 8 : address of the beginning of allocation */
468/* 9 : Size of the USER ZONE */
469/* 10 : ADDRESS of the START FLAG */
470/* 11 : ADDRESS of the END FLAG */
471/* 12 : Rank of creation of the allocation */
472
473/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
474/* NCORE : NB OF CURRENT ALLOCS */
475/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
476/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
7fd59977 477
478
479
480/* ----------------------------------------------------------------------*
481 */
482
483
484/* ----------------------------------------------------------------------*
485 */
486
0d969553 487/* CALCULATE ADDRESS OF T */
fadcea2c 488 mcrlocv_(t, &loc);
0d969553 489 /* CONTROL OF FLAGS IN THE TABLE */
7fd59977 490 i__1 = mcrgene_.ncore;
1ef32e96
RL		 491 for (i__ = 0; i__ < i__1; ++i__) {
492
493 //p to access startaddr and endaddr
494 intptr_t* p = &mcrgene_.icore[i__].startaddr;
495 for (j = 0; j <= 1; ++j) {
496 intptr_t* pp = p + j;
497 if (*pp != -1) {
7fd59977 498
1ef32e96 499 ioff = (*pp - loc) / 8;
7fd59977 500
501 if (t[ioff] != -134744073.) {
502
0d969553 503 /* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS
7fd59977 504 E:',ICORE(J,I) */
0d969553 505 /* AND OF RANK ICORE(12,I) */
1ef32e96 506 macrerr_(pp, p + 2);
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 */
1ef32e96 512 *pp = -1;
7fd59977 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
7fd59977 590 iunit = sizeof(integer);
591 /* Function Body */
592 if (*iofset != 0) {
593 AdvApp2Var_SysBase::mcrdelt_(&iunit,
594 nbelem,
1ef32e96 595 itablo,
7fd59977 596 iofset,
597 iercod);
598 } else {
599 *iercod = 0;
600 }
601 return 0 ;
602} /* macrdi4_ */
603
604//=======================================================================
605//function : AdvApp2Var_SysBase::macrdr8_
606//purpose :
607//=======================================================================
608int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
609 integer *,//maxelm,
610 doublereal *xtablo,
fadcea2c 611 intptr_t *iofset,
7fd59977 612 integer *iercod)
613
614{
1ef32e96 615 integer c__8 = 8;
7fd59977 616
617/* ***********************************************************************
618 */
619
0d969553 620/* FUNCTION : */
7fd59977 621/* ---------- */
0d969553 622/* Destruction of dynamic allocation of type DOUBLE PRECISION
7fd59977 623*/
624
0d969553 625/* KEYWORDS : */
7fd59977 626/* ----------- */
0d969553 627/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
7fd59977 628
0d969553 629/* INPUT ARGUMENTS : */
7fd59977 630/* -------------------- */
0d969553
Y		 631/* NBELEM : Nb of units required */
632/* MAXELM : Max nb of units available in XTABLO */
633/* XTABLO : Reference Address of the allocated zone */
634/* IOFSET : Offset */
7fd59977 635
0d969553
Y		 636/* OUTPUT ARGUMENTS : */
637/* ------------------- */
638/* IERCOD : Error Code */
7fd59977 639/* = 0 : OK */
0d969553
Y		 640/* = 1 : Pb of de-allocation of a zone allocated on table */
641/* = 2 : The system refuses the demand of de-allocation */
7fd59977 642
0d969553
Y		 643/* COMMONS USED : */
644/* -------------- */
7fd59977 645
0d969553
Y		 646/* REFERENCES CALLEDS : */
647/* -------------------- */
7fd59977 648/* MCRDELT */
649
0d969553 650/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 651/* ----------------------------------- */
0d969553 652/* (Cf description in the heading of MCRDELT) */
7fd59977 653
7fd59977 654/* > */
655/* ***********************************************************************
656 */
657
7fd59977 658 /* Function Body */
659 if (*iofset != 0) {
1ef32e96 660 AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, xtablo, iofset, iercod);
7fd59977 661 } else {
662 *iercod = 0;
663 }
664 return 0 ;
665} /* macrdr8_ */
666
667//=======================================================================
668//function : macrerr_
669//purpose :
670//=======================================================================
fadcea2c
RL		 671int macrerr_(intptr_t *,//iad,
672 intptr_t *)//nalloc)
7fd59977 673
674{
1ef32e96 675 //integer c__1 = 1;
7fd59977 676 /* Builtin functions */
677 //integer /*s__wsfe(),*/ /*do__fio(),*/ e__wsfe();
678
679 /* Fortran I/O blocks */
1ef32e96 680 //cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
7fd59977 681
682/* ***********************************************************************
683 */
684
0d969553 685/* FUNCTION : */
7fd59977 686/* ---------- */
0d969553 687/* WRITING OF ADDRESS REMOVED IN ALLOCS . */
7fd59977 688
0d969553 689/* KEYWORDS : */
7fd59977 690/* ----------- */
0d969553 691/* ALLOC CONTROL */
7fd59977 692
0d969553
Y		 693/* INPUT ARGUMENTS : */
694/* ------------------ */
695/* IAD : ADDRESS TO INFORM OF REMOVAL */
696/* NALLOC : NUMBER OF ALLOCATION */
7fd59977 697
0d969553 698/* OUTPUT ARGUMENTS : */
7fd59977 699/* --------------------- */
0d969553 700/* NONE */
7fd59977 701
0d969553
Y		 702/* COMMONS USED : */
703/* -------------- */
7fd59977 704
0d969553
Y		 705/* REFERENCES CALLED : */
706/* ------------------- */
7fd59977 707
0d969553 708/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 709/* ----------------------------------- */
7fd59977 710/* > */
711/* ***********************************************************************
712 */
713 /*
714 s__wsfe(&io___1);
715 */
716 /*
717 do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
718 do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
719 do__fio(&c__1, " sur l'allocation ", 18L);
720 do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
721 */
722 AdvApp2Var_SysBase::e__wsfe();
723
724 return 0 ;
725} /* macrerr_ */
726
727
728//=======================================================================
729//function : macrgfl_
730//purpose :
731//=======================================================================
fadcea2c
RL		 732int macrgfl_(intptr_t *iadfld,
733 intptr_t *iadflf,
7fd59977 734 integer *iphase,
735 integer *iznuti)
736
737{
738 /* Initialized data */
739
1ef32e96
RL		 740 /* original code used static integer ifois=0 which served as static
741 initialization flag and was only used to call matrsym_() once; now
742 this flag is not used as matrsym_() always returns 0 and has no
743 useful contents
744 */
745 integer ifois = 1;
7fd59977 746
1ef32e96
RL		 747 char cbid[1];
748 integer ibid, ienr;
749 doublereal* t = 0;
750 integer novfl;
751 intptr_t ioff,iadrfl, iadt;
7fd59977 752
753
754 /* ***********************************************************************
755 */
756
0d969553 757 /* FUNCTION : */
7fd59977 758 /* ---------- */
0d969553
Y		 759 /* IMPLEMENTATION OF TWO FLAGS START AND END OF THE ALLOCATED ZONE */
760 /* AND SETTING TO OVERFLOW OF THE USER SPACE IN PHASE OF PRODUCTION. */
7fd59977 761
0d969553 762 /* KEYWORDS : */
7fd59977 763 /* ----------- */
0d969553 764 /* ALLOCATION, CONTROL, EXCESS */
7fd59977 765
0d969553
Y		 766 /* INPUT ARGUMENTS : */
767 /* ------------------ */
768 /* IADFLD : ADDRESS OF THE START FLAG */
769 /* IADFLF : ADDRESS OF THE END FLAG */
770 /* IPHASE : TYPE OF SOFTWARE VERSION : */
771 /* 0 = OFFICIAL VERSION */
772 /* 1 = PRODUCTION VERSION */
773 /* IZNUTI : SIZE OF THE USER ZONE IN OCTETS */
774
775 /* OUTPUT ARGUMENTS : */
776 /* ------------------ */
777 /* NONE */
7fd59977 778
0d969553 779 /* COMMONS USED : */
7fd59977 780 /* ------------------ */
781
0d969553
Y		 782 /* REFERENCES CALLED : */
783 /* ------------------- */
7fd59977 784 /* CRLOCT,MACRCHK */
785
0d969553
Y		 786 /* DESCRIPTION/NOTES/LIMITATIONS : */
787 /* ------------------------------- */
788
7fd59977 789 /* > */
790 /* ***********************************************************************
791 */
792
793
794
795 /* ***********************************************************************
796 */
797
0d969553 798 /* FUNCTION : */
7fd59977 799 /* ---------- */
0d969553 800 /* TABLE FOR MANAGEMENT OF DYNAMIC ALLOCATIONS OF MEMORY */
7fd59977 801
0d969553 802 /* KEYWORDS : */
7fd59977 803 /* ----------- */
0d969553 804 /* SYSTEM, MEMORY, ALLOCATION */
7fd59977 805
0d969553 806 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
7fd59977 807 /* ----------------------------------- */
808
0d969553 809
7fd59977 810 /* > */
811 /* ***********************************************************************
812 */
0d969553
Y		 813 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
814/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
815/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
816/* 2 : UNIT OF ALLOCATION */
817/* 3 : NB OF ALLOCATED UNITS */
818/* 4 : REFERENCE ADDRESS OF THE TABLE */
819/* 5 : IOFSET */
820/* 6 : STATIC ALLOCATION NUMBER */
821/* 7 : Required allocation size */
822/* 8 : address of the beginning of allocation */
823/* 9 : Size of the USER ZONE */
824/* 10 : ADDRESS of the START FLAG */
825/* 11 : ADDRESS of the END FLAG */
826/* 12 : Rank of creation of the allocation */
827
828/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
829/* NCORE : NB OF CURRENT ALLOCS */
830/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
831/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
832
833
7fd59977 834
835
836
837 /* ----------------------------------------------------------------------*
838 */
839
840
841 if (ifois == 0) {
842 matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
843 ifois = 1;
844 }
845
0d969553 846 /* CALCULATE THE ADDRESS OF T */
fadcea2c 847 mcrlocv_(t, &iadt);
7fd59977 848
0d969553 849 /* CALCULATE THE OFFSET */
7fd59977 850 ioff = (*iadfld - iadt) / 8;
851
0d969553 852 /* SET TO OVERFLOW OF THE USER ZONE IN CASE OF PRODUCTION VERSION */
7fd59977 853 if (*iphase == 1 && novfl == 0) {
854 ienr = *iznuti / 8;
855 maoverf_(&ienr, &t[ioff + 1]);
856 }
857
0d969553 858 /* UPDATE THE START FLAG */
7fd59977 859 t[ioff] = -134744073.;
860
0d969553 861 /* FAKE CALL TO STOP THE DEBUGGER : */
7fd59977 862 iadrfl = *iadfld;
863 macrbrk_();
864
0d969553 865 /* UPDATE THE START FLAG */
7fd59977 866 ioff = (*iadflf - iadt) / 8;
867 t[ioff] = -134744073.;
868
0d969553 869 /* FAKE CALL TO STOP THE DEBUGGER : */
7fd59977 870 iadrfl = *iadflf;
871 macrbrk_();
872
873 return 0 ;
874} /* macrgfl_ */
875
876//=======================================================================
877//function : macrmsg_
878//purpose :
879//=======================================================================
880int macrmsg_(const char *,//crout,
881 integer *,//num,
882 integer *it,
883 doublereal *xt,
884 const char *ct,
885 ftnlen ,//crout_len,
886 ftnlen ct_len)
887
888{
889
890 /* Local variables */
1ef32e96
RL		 891 integer inum, iunite;
892 char cfm[80], cln[3];
7fd59977 893
894 /* Fortran I/O blocks */
1ef32e96
RL		 895 cilist io___5 = { 0, 0, 0, cfm, 0 };
896 cilist io___6 = { 0, 0, 0, cfm, 0 };
897 cilist io___7 = { 0, 0, 0, cfm, 0 };
7fd59977 898
899
900/* ***********************************************************************
901 */
902
0d969553 903/* FUNCTION : */
7fd59977 904/* ---------- */
0d969553 905/* MESSAGING OF ROUTINES OF ALLOCATION */
7fd59977 906
0d969553 907/* KEYWORDS : */
7fd59977 908/* ----------- */
0d969553 909/* ALLOC, MESSAGE */
7fd59977 910
0d969553
Y		 911/* INPUT ARGUMENTSEE : */
912/* ------------------- */
913/* CROUT : NAME OF THE CALLING ROUTINE : MCRRQST, MCRDELT, MCRLIST
7fd59977 914*/
0d969553
Y		 915/* ,CRINCR OR CRPROT */
916/* NUM : MESSAGE NUMBER */
917/* IT : TABLE OF INTEGER DATA */
918/* XT : TABLE OF REAL DATA */
7fd59977 919/* CT : ------------------ CHARACTER */
920
0d969553 921/* OUTPUT ARGUMENTS : */
7fd59977 922/* --------------------- */
0d969553 923/* NONE */
7fd59977 924
0d969553 925/* COMMONS USED : */
7fd59977 926/* ------------------ */
927
0d969553 928/* REFERENCES CALLED : */
7fd59977 929/* --------------------- */
930
0d969553 931/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 932/* ----------------------------------- */
933
0d969553
Y		 934/* ROUTINE FOR TEMPORARY USE, WAITING FOR THE 'NEW' MESSAGE */
935/* (STRIM 3.3 ?), TO MAKE THE ROUTINES OF ALLOC USABLE */
936/* IN STRIM T-M . */
7fd59977 937
0d969553
Y		 938/* DEPENDING ON THE LANGUAGE, WRITING OF THE REQUIRED MESSAGE ON */
939/* UNIT IMP . */
940/* (REUSE OF SPECIFS OF VFORMA) */
7fd59977 941
0d969553
Y		 942/* THE MESSAGE IS INITIALIZED AT 'MESSAGE MISSING', AND IT IS */
943/* REPLACED BY THE REQUIRED MESSAGE IF EXISTS. */
7fd59977 944/* > */
945/* ***********************************************************************
946 */
947
948/* LOCAL : */
949
950/* ----------------------------------------------------------------------*
951 */
0d969553
Y		 952/* FIND MESSAGE DEPENDING ON THE LANGUAGE , THE ROUTINE */
953/* AND THE MESSAGE NUMBER */
7fd59977 954
0d969553 955/* READING OF THE LANGUAGE : */
7fd59977 956 /* Parameter adjustments */
957 ct -= ct_len;
958 --xt;
959 --it;
960
961 /* Function Body */
962 mamdlng_(cln, 3L);
963
0d969553
Y		 964/* INUM : TYPE OF MESSAGE : 0 AS TEXT, 1 1 INTEGER TO BE WRITTEN */
965/* -1 MESSAGE INEXISTING (1 INTEGER AND 1 CHAIN) */
7fd59977 966
967 inum = -1;
968/*
969 if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
970 __s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
971e de nom : ',A8)", 80L, 71L);
972 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
973 if (*num == 1) {
974 inum = 1;
975 __s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
976ee(s) : ',I6,/)", 80L, 62L);
977 } else if (*num == 2) {
978 inum = 1;
979 __s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
980 } else if (*num == 3) {
981 inum = 1;
982 __s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
983 }
984 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
985 if (*num == 1) {
986 inum = 0;
987 __s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
988e pas ')", 80L, 56L);
989 } else if (*num == 2) {
990 inum = 0;
991 __s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
992ion de memoire ')", 80L, 65L);
993 }
994 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
995 if (*num == 1) {
996 inum = 1;
997 __s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
998 atteint :',I6)", 80L, 62L);
999 } else if (*num == 2) {
1000 inum = 1;
1001 __s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
1002 40L);
1003 } else if (*num == 3) {
1004 inum = 1;
1005 __s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
1006de ',I12,' octets')", 80L, 66L);
1007 }
1008 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1009 if (*num == 1) {
1010 inum = 0;
1011 __s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
1012iste pas')", 80L, 57L);
1013 }
1014 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1015 if (*num == 1) {
1016 inum = 1;
1017 __s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
1018) : ',I12)", 80L, 57L);
1019 }
1020 }
1021
1022 } else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
1023 __s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
1024mm des Namens : ',A8)", 80L, 76L);
1025 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1026 if (*num == 1) {
1027 inum = 1;
1028 __s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
1029sung(en) : ',I6,/)", 80L, 65L);
1030 } else if (*num == 2) {
1031 inum = 1;
1032 __s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
1033 } else if (*num == 3) {
1034 inum = 1;
1035 __s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
1036 41L);
1037 }
1038 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1039 if (*num == 1) {
1040 inum = 0;
1041 __s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
1042 nicht !! ')", 80L, 59L);
1043 } else if (*num == 2) {
1044 inum = 0;
1045 __s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
1046Zuweisung !!')", 80L, 61L);
1047 }
1048 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1049 if (*num == 1) {
1050 inum = 1;
1051 __s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
1052icht :',I6)", 80L, 58L);
1053 } else if (*num == 2) {
1054 inum = 1;
1055 __s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
1056 ;
1057 } else if (*num == 3) {
1058 inum = 1;
1059 __s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
1060,I12,' Bytes')", 80L, 61L);
1061 }
1062 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1063 if (*num == 1) {
1064 inum = 0;
1065 __s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
1066stiert nicht !! ')", 80L, 65L);
1067 }
1068 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1069 if (*num == 1) {
1070 inum = 1;
1071 __s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
1072: ',I12)", 80L, 55L);
1073 }
1074 }
1075
1076 } else {
1077 __s__copy(cfm, "(' Message number ',I5,' is missing ' \
1078 ,'for program named: ',A8)", 80L, 93L);
1079 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1080 if (*num == 1) {
1081 inum = 1;
1082 __s__copy(cfm, "(/,' number of memory allocations carried out: \
1083',I6,/)", 80L, 54L);
1084 } else if (*num == 2) {
1085 inum = 1;
1086 __s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
1087 } else if (*num == 3) {
1088 inum = 1;
1089 __s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
1090 }
1091 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1092 if (*num == 1) {
1093 inum = 0;
1094 __s__copy(cfm, "(' Memory allocation to delete does not exist !\
1095! ')", 80L, 51L);
1096 } else if (*num == 2) {
1097 inum = 0;
1098 __s__copy(cfm, "(' System refuses deletion of memory allocation\
1099 !! ')", 80L, 53L);
1100 }
1101 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1102 if (*num == 1) {
1103 inum = 1;
1104 __s__copy(cfm, "(' max number of memory allocations reached :',\
1105I6)", 80L, 50L);
1106 } else if (*num == 2) {
1107 inum = 1;
1108 __s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
1109 40L);
1110 } else if (*num == 3) {
1111 inum = 1;
1112 __s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
1113' bytes ')", 80L, 57L);
1114 }
1115 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1116 if (*num == 1) {
1117 inum = 0;
1118 __s__copy(cfm, "(' Memory allocation to increment does not exis\
1119t !! ')", 80L, 54L);
1120 }
1121 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1122 if (*num == 1) {
1123 inum = 1;
1124 __s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
1125',I12)", 80L, 53L);
1126 }
1127 }
1128 }
1129 */
1130 /* ----------------------------------------------------------------------*
1131 */
0d969553 1132 /* iMPLEMENTATION OF WRITE , WITH OR WITHOUT DATA : */
7fd59977 1133
1134 iunite = AdvApp2Var_SysBase::mnfnimp_();
1135 if (inum == 0) {
1136 io___5.ciunit = iunite;
1137 /*
1138 s__wsfe(&io___5);
1139 */
1140 AdvApp2Var_SysBase::e__wsfe();
1141 } else if (inum == 1) {
1142 io___6.ciunit = iunite;
1143 /*
1144 s__wsfe(&io___6);
1145 */
1146 /*
1147 do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
1148 */
1149 AdvApp2Var_SysBase::e__wsfe();
1150 } else {
0d969553 1151 /* MESSAGE DOES NOT EXIST ... */
7fd59977 1152 io___7.ciunit = iunite;
1153 /*
1154 s__wsfe(&io___7);
1155 */
1156 /*
1157 do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
1158 do__fio(&c__1, crout, crout_len);
1159 */
1160 AdvApp2Var_SysBase::e__wsfe();
1161 }
1162
1163 return 0;
1164} /* macrmsg_ */
1165//=======================================================================
1166//function : macrstw_
1167//purpose :
1168//=======================================================================
fadcea2c
RL		 1169int macrstw_(intptr_t *,//iadfld,
1170 intptr_t *,//iadflf,
7fd59977 1171 integer *)//nalloc)
1172
1173{
1174 return 0 ;
1175} /* macrstw_ */
1176
1177//=======================================================================
1178//function : madbtbk_
1179//purpose :
1180//=======================================================================
1181int madbtbk_(integer *indice)
1182{
1183 *indice = 0;
1184 return 0 ;
1185} /* madbtbk_ */
1186
1187//=======================================================================
1188//function : AdvApp2Var_SysBase::maermsg_
1189//purpose :
1190//=======================================================================
1191int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
1192 integer *,//icoder,
1193 ftnlen )//cnompg_len)
1194
1195{
1196 return 0 ;
1197} /* maermsg_ */
1198
1199//=======================================================================
1200//function : magtlog_
1201//purpose :
1202//=======================================================================
1203int magtlog_(const char *cnmlog,
1204 const char *,//chaine,
1205 integer *long__,
1206 integer *iercod,
1207 ftnlen cnmlog_len,
1208 ftnlen )//chaine_len)
1209
1210{
1211
1212 /* Local variables */
1ef32e96
RL		 1213 char cbid[255];
1214 integer ibid, ier;
7fd59977 1215
1216
1217/* **********************************************************************
1218*/
1219
0d969553 1220/* FUNCTION : */
7fd59977 1221/* ---------- */
0d969553
Y		 1222/* RETURN TRANSLATION OF "NAME LOGIC STRIM" IN */
1223/* "INTERNAL SYNTAX" CORRESPONDING TO "PLACE OF RANKING" */
7fd59977 1224
0d969553 1225/* KEYWORDS : */
7fd59977 1226/* ----------- */
1227/* NOM LOGIQUE STRIM , TRADUCTION */
1228
0d969553 1229/* INPUT ARGUMENTS : */
7fd59977 1230/* ------------------ */
0d969553 1231/* CNMLOG : NAME OF "NAME LOGIC STRIM" TO TRANSLATE */
7fd59977 1232
0d969553 1233/* OUTPUT ARGUMENTS : */
7fd59977 1234/* ------------------- */
0d969553
Y		 1235/* CHAINE : ADDRESS OF "PLACE OF RANKING" */
1236/* LONG : USEFUL LENGTH OF "PLACE OF RANKING" */
1237/* IERCOD : ERROR CODE */
7fd59977 1238/* IERCOD = 0 : OK */
0d969553
Y		 1239/* IERCOD = 5 : PLACE OF RANKING CORRESPONDING TO INEXISTING LOGIC NAME */
1240
1241/* IERCOD = 6 : TRANSLATION TOO LONG FOR THE 'CHAIN' VARIABLE */
1242/* IERCOD = 7 : CRITICAL ERROR */
7fd59977 1243
0d969553 1244/* COMMONS USED : */
7fd59977 1245/* ---------------- */
0d969553 1246/* NONE */
7fd59977 1247
0d969553
Y		 1248/* REFERENCES CALLED : */
1249/* --------------------- */
7fd59977 1250/* GNMLOG, MACHDIM */
1251
0d969553
Y		 1252/* DESCRIPTION/NOTES/LIMITATIONS : */
1253/* ------------------------------- */
7fd59977 1254
0d969553 1255/* SPECIFIC SGI ROUTINE */
7fd59977 1256
0d969553
Y		 1257/* IN ALL CASES WHEN IERCOD IS >0, NO RESULT IS RETURNED*/
1258/* NOTION OF "USER SYNTAX' AND "INTERNAL SYNTAX" */
7fd59977 1259/* --------------------------------------------------- */
1260
0d969553
Y		 1261/* THE "USER SYNTAX" IS THE SYNTAX WHERE THE USER*/
1262/* VISUALIZES OR INDICATES THE FILE OR DIRECTORY NAME */
1263/* DURING A SESSION OF STRIM100 */
7fd59977 1264
0d969553
Y		 1265/* "INTERNAL SYNTAX" IS SYNTAX USED TO CARRY OUT */
1266/* OPERATIONS OF FILE PROCESSING INSIDE THE CODE */
7fd59977 1267/* (OPEN,INQUIRE,...ETC) */
1268
7fd59977 1269/* > */
1270/* ***********************************************************************
1271 */
1272/* DECLARATIONS */
1273/* ***********************************************************************
1274 */
1275
1276
1277/* ***********************************************************************
1278 */
0d969553 1279/* PROCESSING */
7fd59977 1280/* ***********************************************************************
1281 */
1282
1283 *long__ = 0;
1284 *iercod = 0;
1285
0d969553 1286 /* CONTROL OF EXISTENCE OF THE LOGIC NAME */
7fd59977 1287
1288 matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
1289 if (ier == 1) {
1290 goto L9500;
1291 }
1292 if (ier == 2) {
1293 goto L9700;
1294 }
1295
0d969553 1296 /* CONTROL OF THE LENGTH OF CHAIN */
7fd59977 1297
1298 if (ibid > __i__len()/*chaine, chaine_len)*/) {
1299 goto L9600;
1300 }
1301
1302 //__s__copy(chaine, cbid, chaine_len, ibid);
1303 *long__ = ibid;
1304
1305 goto L9999;
1306
1307 /* ***********************************************************************
1308 */
0d969553 1309 /* ERROR PROCESSING */
7fd59977 1310 /* ***********************************************************************
1311 */
1312
1313 L9500:
1314 *iercod = 5;
1315 //__s__copy(chaine, " ", chaine_len, 1L);
1316 goto L9999;
1317
1318 L9600:
1319 *iercod = 6;
1320 //__s__copy(chaine, " ", chaine_len, 1L);
1321 goto L9999;
1322
1323 L9700:
1324 *iercod = 7;
1325 //__s__copy(chaine, " ", chaine_len, 1L);
1326
1327 /* ***********************************************************************
1328 */
0d969553 1329 /* RETURN TO THE CALLING PROGRAM */
7fd59977 1330 /* ***********************************************************************
1331 */
1332
1333 L9999:
1334 return 0;
1335} /* magtlog_ */
1336
1337//=======================================================================
1338//function : mainial_
1339//purpose :
1340//=======================================================================
1341int AdvApp2Var_SysBase::mainial_()
1342{
1343 mcrgene_.ncore = 0;
1ef32e96 1344 mcrgene_.lprot = 0;
7fd59977 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{
1ef32e96 1357 integer c__504 = 504;
7fd59977 1358
1359 /* Initialized data */
1360
1ef32e96 1361 doublereal buff0[63] = {
7fd59977 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 */
1ef32e96
RL		 1372 integer i__;
1373 doublereal buffx[63];
1374 integer nbfois, noffst, nreste, nufois;
7fd59977 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{
1ef32e96 1614 integer imod;
7fd59977 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
1ef32e96 1674 integer ifois = 0;
7fd59977 1675
1676 /* System generated locals */
1677 integer i__1;
1678
1679 /* Local variables */
1ef32e96
RL		 1680 integer ibid;
1681 doublereal buff[63];
1682 integer ioct, indic, nrest, icompt;
7fd59977 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 */
1ef32e96 1913 char chainx[255];
7fd59977 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
1ef32e96 2002 integer ntab = 0;
7fd59977 2003
2004 /* System generated locals */
2005 integer i__1, i__2;
2006
2007 /* Local variables */
1ef32e96
RL		 2008 intptr_t ideb;
2009 doublereal dtab[32000];
2010 intptr_t itab[160] /* was [4][40] */;
2011 intptr_t ipre;
2012 integer i__, j, k;
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{
1ef32e96
RL		 2180 integer ibid;
2181 doublereal xbid;
2182 integer noct, iver, ksys, i__, n, nrang,
7fd59977 2183 ibyte, ier;
1ef32e96
RL		 2184 intptr_t iadfd, iadff, iaddr, loc; /* Les adrresses en long*/
2185 integer kop;
7fd59977 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
1ef32e96 2313 n = -1;
fadcea2c 2314 mcrlocv_(t, &loc);
7fd59977 2315
1ef32e96
RL		 2316 for (i__ = mcrgene_.ncore - 1; i__ >= 0; --i__) {
2317 if (*iunit == mcrgene_.icore[i__].unit && *isize ==
2318 mcrgene_.icore[i__].reqsize && loc == mcrgene_.icore[i__].loc
2319 && *iofset == mcrgene_.icore[i__].offset) {
7fd59977 2320 n = i__;
2321 goto L1100;
2322 }
2323/* L1001: */
2324 }
2325L1100:
2326
0d969553 2327/* IF THE ALLOCATION DOES NOT EXIST, LEAVE */
7fd59977 2328
1ef32e96 2329 if (n < 0) {
7fd59977 2330 goto L9003;
2331 }
2332
0d969553 2333/* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */
7fd59977 2334
1ef32e96
RL		 2335 ksys = mcrgene_.icore[n].alloctype;
2336 ibyte = mcrgene_.icore[n].size;
2337 iaddr = mcrgene_.icore[n].addr;
2338 iadfd = mcrgene_.icore[n].startaddr;
2339 iadff = mcrgene_.icore[n].endaddr;
2340 nrang = mcrgene_.icore[n].rank;
7fd59977 2341
0d969553 2342/* Control of flags */
7fd59977 2343
2344 madbtbk_(&iver);
2345 if (iver == 1) {
2346 macrchk_();
2347 }
2348
1ef32e96 2349 if (ksys == static_allocation) {
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 */
1ef32e96
RL		 2369 ++mcrstac_.ndelt[ksys];
2370 mcrstac_.nbyte[ksys] -= mcrgene_.icore[n].unit *
2371 mcrgene_.icore[n].reqsize;
7fd59977 2372
0d969553 2373/* REMOVAL OF PARAMETERS IN MCRGENE */
1ef32e96
RL		 2374 if (n < MAX_ALLOC_NB - 1) {
2375 noct = (mcrgene_.ncore - (n + 1)) * sizeof(mcrgene_.icore[0]);
fadcea2c 2376 AdvApp2Var_SysBase::mcrfill_(&noct,
1ef32e96
RL		 2377 &mcrgene_.icore[n + 1],
2378 &mcrgene_.icore[n]);
7fd59977 2379 }
2380 --mcrgene_.ncore;
2381
0d969553 2382/* *** Set to overflow of IOFSET */
fadcea2c
RL		 2383 {
2384 /* nested scope needed to avoid gcc compilation error crossing
2385 initialization with goto*/
2386 /* assign max positive integer to *iofset */
2387 const size_t shift = sizeof (*iofset) * 8 - 1;
2388 *iofset = (uintptr_t(1) << shift) - 1 /*2147483647 for 32bit*/;
2389 }
7fd59977 2390 goto L9900;
2391
2392/* ----------------------------------------------------------------------*
2393 */
0d969553 2394/* ERROR PROCESSING */
7fd59977 2395
2396L9001:
0d969553 2397/* REFUSE DE-ALLOCATION BY ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
7fd59977 2398 *iercod = 1;
2399 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2400 maostrd_();
2401 goto L9900;
2402
0d969553 2403/* REFUSE DE-ALLOCATION BY THE SYSTEM */
7fd59977 2404L9002:
2405 *iercod = 2;
2406 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2407 macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
2408 maostrd_();
2409 goto L9900;
2410
0d969553 2411/* ALLOCATION DOES NOT EXIST */
7fd59977 2412L9003:
2413 *iercod = 3;
2414 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2415 maostrd_();
2416 goto L9900;
2417
2418L9900:
2419
2420 return 0 ;
2421
2422} /* mcrdelt_ */
2423
2424
2425/*
2426C*********************************************************************
2427C
0d969553 2428C FUNCTION :
7fd59977 2429C ----------
0d969553 2430C Transfer a memory zone in another by managing intersections
7fd59977 2431C
0d969553 2432C KEYWORDS :
7fd59977 2433C -----------
0d969553 2434C MANIPULATION, MEMORY, TRANSFER, CHARACTER
7fd59977 2435C
0d969553
Y		 2436C INPUT ARGUMENTS :
2437C -----------------
2438C nb_car : integer*4 number of characters to transfer.
2439C source : source memory zone.
7fd59977 2440C
0d969553 2441C OUTPUT ARGUMENTS :
7fd59977 2442C -------------------
0d969553 2443C dest : zone memory destination.
7fd59977 2444C
0d969553 2445C COMMONS USED :
7fd59977 2446C ----------------
2447C
0d969553 2448C REFERENCES CALLED :
7fd59977 2449C -------------------
2450C
0d969553 2451C DEMSCRIPTION/NOTES/LIMITATIONS :
7fd59977 2452C -----------------------------------
2453C Routine portable UNIX (SGI, ULTRIX, BULL)
2454C
0d969553 2455
7fd59977 2456C>
2457C**********************************************************************
2458*/
2459
2460//=======================================================================
2461//function : AdvApp2Var_SysBase::mcrfill_
2462//purpose :
2463//=======================================================================
2464int AdvApp2Var_SysBase::mcrfill_(integer *size,
fadcea2c
RL		 2465 void *tin,
2466 void *tout)
7fd59977 2467
2468{
fadcea2c
RL		 2469 register char *jmin=static_cast<char*> (tin);
2470 register char *jmout=static_cast<char*> (tout);
2471 if (mcrfill_ABS(jmout-jmin) >= *size)
7fd59977 2472 memcpy( tout, tin, *size);
2473 else if (tin > tout)
2474 {
2475 register integer n = *size;
7fd59977 2476 while (n-- > 0) *jmout++ = *jmin++;
2477 }
2478 else
2479 {
2480 register integer n = *size;
fadcea2c
RL		 2481 jmin+=n;
2482 jmout+=n;
7fd59977 2483 while (n-- > 0) *--jmout = *--jmin;
2484 }
2485 return 0;
2486}
2487
2488
2489/*........................................................................*/
2490/* */
0d969553 2491/* FUNCTION : */
7fd59977 2492/* ---------- */
0d969553 2493/* Routines for management of the dynamic memory. */
7fd59977 2494/* */
0d969553 2495/* Routine mcrfree */
7fd59977 2496/* -------------- */
2497/* */
0d969553 2498/* Desallocation of a memory zone . */
7fd59977 2499/* */
0d969553 2500/* CALL MCRFREE (IBYTE,IADR,IER) */
7fd59977 2501/* */
0d969553 2502/* IBYTE INTEGER*4 : Nb of Octets to free */
7fd59977 2503/* */
0d969553 2504/* IADR POINTEUR : Start Address */
7fd59977 2505/* */
0d969553 2506/* IER INTEGER*4 : Return Code */
7fd59977 2507/* */
7fd59977 2508/* */
2509/*........................................................................*/
2510/* */
2511
2512//=======================================================================
2513//function : mcrfree_
2514//purpose :
2515//=======================================================================
2516int mcrfree_(integer *,//ibyte,
fadcea2c 2517 void* *iadr,
7fd59977 2518 integer *ier)
2519
2520{
2521 *ier=0;
fadcea2c
RL		 2522 Standard::Free(*iadr);
2523 //Standard::Free always nullifies address, so check becomes incorrect
2524 //if ( !*iadr ) *ier = 1;
7fd59977 2525 return 0;
2526}
2527
2528/*........................................................................*/
2529/* */
2530/* FONCTION : */
2531/* ---------- */
0d969553 2532/* Routines for management of the dynamic memory. */
7fd59977 2533/* */
0d969553 2534/* Routine mcrgetv */
7fd59977 2535/* -------------- */
2536/* */
0d969553 2537/* Demand of memory allocation. */
7fd59977 2538/* */
0d969553 2539/* CALL MCRGETV(IBYTE,IADR,IER) */
7fd59977 2540/* */
0d969553 2541/* IBYTE (INTEGER*4) Nb of Bytes of allocation required */
7fd59977 2542/* */
0d969553 2543/* IADR (INTEGER*4) : Result. */
7fd59977 2544/* */
0d969553 2545/* IER (INTEGER*4) : Error Code : */
7fd59977 2546/* */
2547/* = 0 ==> OK */
2548/* = 1 ==> Allocation impossible */
2549/* = -1 ==> Ofset > 2**31 - 1 */
2550/* */
0d969553 2551
7fd59977 2552/* */
2553/*........................................................................*/
2554
2555//=======================================================================
2556//function : mcrgetv_
2557//purpose :
2558//=======================================================================
2559int mcrgetv_(integer *sz,
fadcea2c 2560 void* *iad,
7fd59977 2561 integer *ier)
2562
2563{
2564
2565 *ier = 0;
fadcea2c 2566 *iad = Standard::Allocate(*sz);
7fd59977 2567 if ( !*iad ) *ier = 1;
2568 return 0;
2569}
2570
2571
2572//=======================================================================
2573//function : mcrlist_
2574//purpose :
2575//=======================================================================
1ef32e96 2576int AdvApp2Var_SysBase::mcrlist_(integer *ier) const
7fd59977 2577
2578{
2579 /* System generated locals */
2580 integer i__1;
2581
2582 /* Builtin functions */
2583
2584 /* Local variables */
1ef32e96
RL		 2585 char cfmt[1];
2586 doublereal dfmt;
2587 integer ifmt, i__, nufmt, ntotal;
2588 char subrou[7];
7fd59977 2589
2590
2591/************************************************************************
2592*******/
2593
0d969553 2594/* FUNCTION : */
7fd59977 2595/* ---------- */
0d969553 2596/* PRINT TABLE OF CURRENT DYNAMIC ALLOCATIONS */
7fd59977 2597
0d969553 2598/* KEYWORDS : */
7fd59977 2599/* ----------- */
0d969553 2600/* SYSTEM, ALLOCATION, MEMORY, LIST */
7fd59977 2601
0d969553 2602/* INPUT ARGUMENTS : */
7fd59977 2603/* ------------------ */
0d969553 2604/* . NONE */
7fd59977 2605
0d969553 2606/* OUTPUT ARGUMENTS : */
7fd59977 2607/* ------------------- */
2608/* * : */
2609/* * : */
0d969553 2610/* IERCOD : ERROR CODE */
7fd59977 2611
2612/* IERCOD = 0 : OK */
0d969553 2613/* IERCOD > 0 : SERIOUS ERROR */
7fd59977 2614/* IERCOD < 0 : WARNING */
0d969553
Y		 2615/* IERCOD = 1 : ERROR DESCRIPTION */
2616/* IERCOD = 2 : ERROR DESCRIPTION */
7fd59977 2617
0d969553 2618/* COMMONS USED : */
7fd59977 2619/* ---------------- */
2620
2621/* MCRGENE VFORMT */
2622
0d969553 2623/* REFERENCES CALLED : */
7fd59977 2624/* ---------------------- */
2625
2626/* Type Name */
2627/* VFORMA */
2628
0d969553 2629/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2630/* ----------------------------------- */
0d969553
Y		 2631/* . NONE */
2632
7fd59977 2633
7fd59977 2634
2635/* > */
2636/* ***********************************************************************
2637 */
2638
2639/* INCLUDE MCRGENE */
2640/* ***********************************************************************
2641 */
2642
0d969553 2643/* FUNCTION : */
7fd59977 2644/* ---------- */
0d969553 2645/* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
7fd59977 2646
0d969553 2647/* KEYWORDS : */
7fd59977 2648/* ----------- */
0d969553 2649/* SYSTEM, MEMORY, ALLOCATION */
7fd59977 2650
0d969553 2651/* DEMSCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2652/* ----------------------------------- */
2653
0d969553 2654
7fd59977 2655/* > */
2656/* ***********************************************************************
2657 */
2658
0d969553
Y		 2659/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2660/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2661/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2662/* 2 : UNIT OF ALLOCATION */
2663/* 3 : NB OF ALLOCATED UNITS */
2664/* 4 : REFERENCE ADDRESS OF THE TABLE */
7fd59977 2665/* 5 : IOFSET */
0d969553
Y		 2666/* 6 : STATIC ALLOCATION NUMBER */
2667/* 7 : Required allocation size */
2668/* 8 : address of the beginning of allocation */
2669/* 9 : Size of the USER ZONE */
2670/* 10 : ADDRESS of the START FLAG */
2671/* 11 : ADDRESS of the END FLAG */
2672/* 12 : Rank of creation of the allocation */
2673
2674/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2675/* NCORE : NB OF CURRENT ALLOCS */
2676/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2677/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
7fd59977 2678
2679
2680
2681/* ----------------------------------------------------------------------*
2682 */
2683
2684
2685/* ----------------------------------------------------------------------*
2686 */
2687
2688 *ier = 0;
2689 //__s__copy(subrou, "MCRLIST", 7L, 7L);
2690
0d969553 2691/* WRITE HEADING */
7fd59977 2692
2693 nufmt = 1;
2694 ifmt = mcrgene_.ncore;
2695 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2696
2697 ntotal = 0;
2698
2699 i__1 = mcrgene_.ncore;
1ef32e96 2700 for (i__ = 0; i__ < i__1; ++i__) {
7fd59977 2701 nufmt = 2;
1ef32e96 2702 ifmt = mcrgene_.icore[i__].unit * mcrgene_.icore[i__].reqsize
7fd59977 2703 ;
2704 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2705 ntotal += ifmt;
2706/* L1001: */
2707 }
2708
2709 nufmt = 3;
2710 ifmt = ntotal;
2711 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2712
2713 return 0 ;
2714} /* mcrlist_ */
2715
2716
2717//=======================================================================
2718//function : mcrlocv_
2719//purpose :
2720//=======================================================================
fadcea2c
RL		 2721int mcrlocv_(void* t,
2722 intptr_t *l)
7fd59977 2723
2724{
fadcea2c 2725 *l = reinterpret_cast<intptr_t> (t);
7fd59977 2726 return 0 ;
2727}
2728
2729//=======================================================================
2730//function : AdvApp2Var_SysBase::mcrrqst_
2731//purpose :
2732//=======================================================================
2733int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
2734 integer *isize,
fadcea2c
RL		 2735 void *t,
2736 intptr_t *iofset,
7fd59977 2737 integer *iercod)
2738
2739{
2740
2741 integer i__1, i__2;
2742
2743 /* Local variables */
1ef32e96
RL		 2744 doublereal dfmt;
2745 integer ifmt, iver;
2746 char subr[7];
2747 integer ksys , ibyte, irest, isyst, ier;
2748 intptr_t iadfd, iadff, iaddr,lofset, loc;
2749 integer izu;
7fd59977 2750
2751
2752/* **********************************************************************
2753*/
2754
0d969553 2755/* FUNCTION : */
7fd59977 2756/* ---------- */
0d969553 2757/* IMPLEMENTATION OF DYNAMIC MEMORY ALLOCATION */
7fd59977 2758
0d969553 2759/* KEYWORDS : */
7fd59977 2760/* ----------- */
0d969553 2761/* SYSTEM, ALLOCATION, MEMORY, REALISATION */
7fd59977 2762
0d969553 2763/* INPUT ARGUMENTS : */
7fd59977 2764/* ------------------ */
0d969553
Y		 2765/* IUNIT : NUMBER OF OCTET OF THE UNIT OF ALLOCATION */
2766/* ISIZE : NUMBER OF UNITS REQUIRED */
2767/* T : REFERENCE ADDRESS */
7fd59977 2768
0d969553 2769/* OUTPUT ARGUMENTS : */
7fd59977 2770/* ------------------- */
0d969553
Y		 2771/* IOFSET : OFFSET */
2772/* IERCOD : ERROR CODE, */
7fd59977 2773/* = 0 : OK */
0d969553
Y		 2774/* = 1 : MAX NB OF ALLOCS REACHED */
2775/* = 2 : ARGUMENTS INCORRECT */
2776/* = 3 : REFUSED DYNAMIC ALLOCATION */
7fd59977 2777
0d969553 2778/* COMMONS USED : */
7fd59977 2779/* ---------------- */
2780/* MCRGENE, MCRSTAC */
2781
0d969553 2782/* REFERENCES CALLED : */
7fd59977 2783/* ----------------------- */
2784/* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
2785
0d969553 2786/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2787/* ----------------------------------- */
2788
0d969553 2789/* 1) USER */
7fd59977 2790/* -------------- */
2791
0d969553
Y		 2792/* T IS THE ADDRESS OF A TABLE, IOFSET REPRESENTS THE DEPLACEMENT IN */
2793/* UNITS OF IUNIT OCTETS BETWEEN THE ALLOCATED ZONE AND TABLE T */
2794/* IERCOD=0 SIGNALS THAT THE ALLOCATION WORKS WELL, ANY OTHER */
2795/* VALUE INDICATES A BUG. */
2796
2797/* EXAMPLE : */
2798/* LET THE DECLARATION REAL*4 T(1), SO IUNIT=4 . */
2799/* CALL TO MCRRQST PORODUCES DYNAMIC ALLOCATION */
2800/* AND GIVES VALUE TO VARIABLE IOFSET, */
2801/* IF IT IS REQUIRED TO WRITE 1. IN THE 5TH ZONE REAL*4 */
2802/* ALLOCATED IN THIS WAY, MAKE: */
7fd59977 2803/* T(5+IOFSET)=1. */
2804
0d969553 2805/* CASE OF ERRORS : */
7fd59977 2806/* --------------- */
2807
0d969553
Y		 2808/* IERCOD=1 : MAX NB OF ALLOCATION REACHED (ACTUALLY 200) */
2809/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2810/* "The max number of memory allocation is reached : ,N" */
7fd59977 2811
0d969553
Y		 2812/* IERCOD=2 : ARGUMENT IUNIT INCORRECT AS IT IS DIFFERENT FROM 1,2,4 OR 8 */
2813/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2814/* "Unit OF allocation invalid : ,IUNIT" */
7fd59977 2815
0d969553
Y		 2816/* IERCOD=3 : REFUSED DYNAMIC ALLOCATION (MORE PLACE IN MEMORY) */
2817/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2818/* "The system refuses dynamic allocation of memory of N octets"
7fd59977 2819*/
0d969553 2820/* with completev display of all allocations carried out till now */
7fd59977 2821
2822
0d969553 2823/* 2) DESIGNER */
7fd59977 2824/* -------------- */
2825
0d969553
Y		 2826/* MCRRQST MAKES DYNAMIC ALLOCATION OF VIRTUAL MEMORY ON THE BASE */
2827/* OF ENTITIES OF 8 OCTETS (QUADWORDS), WHILE THE ALLOCATION IS REQUIRED BY */
2828/* UNITS OF IUNIT OCTETS (1,2,4,8). */
2829
2830/* THE REQUIRED QUANTITY IS IUNIT*ISIZE OCTETS, THIS VALUE IS ROUNDED */
2831/* SO THAT THE ALLOCATION WAS AN INTEGER NUMBER OF QUADWORDS. */
2832
7fd59977 2833
7fd59977 2834
2835/* > */
2836/* ***********************************************************************
2837 */
2838
0d969553
Y		 2839/* COMMON OF PARAMETRES */
2840/* COMMON OF INFORMATION ON STATISTICS */
7fd59977 2841/* INCLUDE MCRGENE */
2842
2843/* ***********************************************************************
2844 */
0d969553 2845/* FUNCTION : */
7fd59977 2846/* ---------- */
0d969553 2847/* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
7fd59977 2848
0d969553 2849/* KEYWORDS : */
7fd59977 2850/* ----------- */
0d969553 2851/* SYSTEM, MEMORY, ALLOCATION */
7fd59977 2852
0d969553 2853/* DEMSCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2854/* ----------------------------------- */
2855
0d969553 2856
7fd59977 2857/* > */
2858/* ***********************************************************************
2859 */
2860
0d969553
Y		 2861/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2862/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2863/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2864/* 2 : UNIT OF ALLOCATION */
2865/* 3 : NB OF ALLOCATED UNITS */
2866/* 4 : REFERENCE ADDRESS OF THE TABLE */
7fd59977 2867/* 5 : IOFSET */
0d969553
Y		 2868/* 6 : STATIC ALLOCATION NUMBER */
2869/* 7 : Required allocation size */
2870/* 8 : address of the beginning of allocation */
2871/* 9 : Size of the USER ZONE */
2872/* 10 : ADDRESS of the START FLAG */
2873/* 11 : ADDRESS of the END FLAG */
2874/* 12 : Rank of creation of the allocation */
2875
2876/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2877/* NCORE : NB OF CURRENT ALLOCS */
2878/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2879/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2880
7fd59977 2881
2882
2883
2884/* ----------------------------------------------------------------------*
2885 */
0d969553 2886/* 20-10-86 : BF ; INITIAL VERSION */
7fd59977 2887
2888
0d969553
Y		 2889/* NRQST : NUMBER OF ALLOCATIONS */
2890/* NDELT : NUMBER OF LIBERATIONS */
2891/* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2892/* MBYTE : MAX NUMBER OF OCTETS */
7fd59977 2893
7fd59977 2894
2895/* ----------------------------------------------------------------------*
2896 */
2897
7fd59977 2898 /* Function Body */
2899 *iercod = 0;
2900
1ef32e96 2901 if (mcrgene_.ncore >= MAX_ALLOC_NB) {
7fd59977 2902 goto L9001;
2903 }
2904 if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
2905 goto L9002;
2906 }
2907
0d969553 2908/* Calculate the size required by the user */
7fd59977 2909 ibyte = *iunit * *isize;
2910
0d969553 2911/* Find the type of version (Phase of Production or Version Client) */
7fd59977 2912 madbtbk_(&iver);
2913
0d969553 2914/* Control allocated size in Production phase */
7fd59977 2915
2916 if (iver == 1) {
2917
2918 if (ibyte == 0) {
2919 //s__wsle(&io___3);
0d969553 2920 //do__lio(&c__9, &c__1, "Require zero allocation", 26L);
7fd59977 2921 AdvApp2Var_SysBase::e__wsle();
2922 maostrb_();
2923 } else if (ibyte >= 4096000) {
2924 //s__wsle(&io___4);
0d969553 2925 //do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L);
7fd59977 2926 //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
2927 AdvApp2Var_SysBase::e__wsle();
2928 maostrb_();
2929 }
2930
2931 }
2932
0d969553
Y		 2933/* CALCULATE THE SIZE OF THE USER ZONE (IZU) */
2934/* . add size required by the user (IBYTE) */
2935/* . add delta for alinement with the base */
2936/* . round to multiple of 8 above */
7fd59977 2937
fadcea2c 2938 mcrlocv_(t, &loc);
7fd59977 2939 izu = ibyte + loc % *iunit;
2940 irest = izu % 8;
2941 if (irest != 0) {
2942 izu = izu + 8 - irest;
2943 }
2944
0d969553
Y		 2945/* CALCULATE THE SIZE REQUIRED FROM THE PRIMITIVE OF ALLOC */
2946/* . add size of the user zone */
2947/* . add 8 for alinement of start address of */
2948/* allocation on multiple of 8 so that to be able to */
2949/* set flags with Double Precision without other pb than alignement */
2950/* . add 16 octets for two flags */
7fd59977 2951
2952 ibyte = izu + 24;
2953
0d969553 2954/* DEMAND OF ALLOCATION */
7fd59977 2955
2956 isyst = 0;
2957/* L1001: */
2958/* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
2959/* ALLOCATION SUR TABLE */
2960/* KSYS = 1 */
2961/* KOP = 1 */
2962/* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
2963/* IF ( IER .NE. 0 ) THEN */
2964/* ISYST=1 */
2965/* GOTO 1001 */
2966/* ENDIF */
2967/* ELSE */
2968/* ALLOCATION SYSTEME */
1ef32e96 2969 ksys = heap_allocation;
fadcea2c 2970 mcrgetv_(&ibyte, reinterpret_cast<void**> (&iaddr), &ier);
7fd59977 2971 if (ier != 0) {
2972 goto L9003;
2973 }
2974/* ENDIF */
2975
0d969553 2976/* CALCULATE THE ADDRESSES OF FLAGS */
7fd59977 2977
2978 iadfd = iaddr + 8 - iaddr % 8;
2979 iadff = iadfd + 8 + izu;
2980
0d969553
Y		 2981/* CALCULATE USER OFFSET : */
2982/* . difference between the user start address and the */
2983/* base address */
2984/* . converts this difference in the user unit */
7fd59977 2985
2986 lofset = iadfd + 8 + loc % *iunit - loc;
2987 *iofset = lofset / *iunit;
2988
0d969553 2989/* If phase of production control flags */
7fd59977 2990 if (iver == 1) {
2991 macrchk_();
2992 }
2993
0d969553
Y		 2994/* SET FLAGS */
2995/* . the first flag is set by IADFD and the second by IADFF */
2996/* . if phase of production, set to overflow the ZU */
7fd59977 2997 macrgfl_(&iadfd, &iadff, &iver, &izu);
2998
0d969553 2999/* RANGING OF PARAMETERS IN MCRGENE */
7fd59977 3000
1ef32e96
RL		 3001 mcrgene_.icore[mcrgene_.ncore].prot = mcrgene_.lprot;
3002 mcrgene_.icore[mcrgene_.ncore].unit = *iunit;
3003 mcrgene_.icore[mcrgene_.ncore].reqsize = *isize;
3004 mcrgene_.icore[mcrgene_.ncore].loc = loc;
3005 mcrgene_.icore[mcrgene_.ncore].offset = *iofset;
3006 mcrgene_.icore[mcrgene_.ncore].alloctype = ksys;
3007 mcrgene_.icore[mcrgene_.ncore].size = ibyte;
3008 mcrgene_.icore[mcrgene_.ncore].addr = iaddr;
3009 mcrgene_.icore[mcrgene_.ncore].userzone = mcrgene_.ncore;
3010 mcrgene_.icore[mcrgene_.ncore].startaddr = iadfd;
3011 mcrgene_.icore[mcrgene_.ncore].endaddr = iadff;
3012 mcrgene_.icore[mcrgene_.ncore].rank = mcrgene_.ncore + 1;
7fd59977 3013 ++mcrgene_.ncore;
7fd59977 3014
3015 mcrgene_.lprot = 0;
3016
0d969553 3017/* CALL ALLOWING AUTOIMPLEMENTATION OF THE SET WATCH BY THE DEBUGGER */
7fd59977 3018
fadcea2c 3019 macrstw_(&iadfd, &iadff, &mcrgene_.ncore);
7fd59977 3020
0d969553 3021/* STATISTICS */
7fd59977 3022
1ef32e96
RL		 3023 ++mcrstac_.nrqst[ksys];
3024 mcrstac_.nbyte[ksys] += mcrgene_.icore[mcrgene_.ncore - 1].unit *
3025 mcrgene_.icore[mcrgene_.ncore - 1].reqsize;
7fd59977 3026/* Computing MAX */
1ef32e96
RL		 3027 i__1 = mcrstac_.mbyte[ksys], i__2 = mcrstac_.nbyte[ksys];
3028 mcrstac_.mbyte[ksys] = advapp_max(i__1,i__2);
7fd59977 3029
3030 goto L9900;
3031
3032/* ----------------------------------------------------------------------*
3033 */
0d969553 3034/* ERROR PROCESSING */
7fd59977 3035
0d969553 3036/* MAX NB OF ALLOC REACHED : */
7fd59977 3037L9001:
3038 *iercod = 1;
1ef32e96 3039 ifmt = MAX_ALLOC_NB;
7fd59977 3040 //__s__copy(subr, "MCRRQST", 7L, 7L);
3041 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3042 maostrd_();
3043 goto L9900;
3044
0d969553 3045/* INCORRECT ARGUMENTS */
7fd59977 3046L9002:
3047 *iercod = 2;
3048 ifmt = *iunit;
3049 //__s__copy(subr, "MCRRQST", 7L, 7L);
3050 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3051 goto L9900;
3052
0d969553 3053/* SYSTEM REFUSES ALLOCATION */
7fd59977 3054L9003:
3055 *iercod = 3;
3056 ifmt = ibyte;
3057 //__s__copy(subr, "MCRRQST", 7L, 7L);
3058 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3059 maostrd_();
3060 mcrlist_(&ier);
3061 goto L9900;
3062
3063/* ----------------------------------------------------------------------*
3064 */
3065
3066L9900:
3067 mcrgene_.lprot = 0;
3068 return 0 ;
3069} /* mcrrqst_ */
3070
3071//=======================================================================
3072//function : AdvApp2Var_SysBase::mgenmsg_
3073//purpose :
3074//=======================================================================
3075int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
3076 ftnlen )//nomprg_len)
3077
3078{
3079 return 0;
3080} /* mgenmsg_ */
3081
3082//=======================================================================
3083//function : AdvApp2Var_SysBase::mgsomsg_
3084//purpose :
3085//=======================================================================
3086int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
3087 ftnlen )//nomprg_len)
3088
3089{
3090 return 0;
3091} /* mgsomsg_ */
3092
3093
3094/*
3095C
3096C*****************************************************************************
3097C
0d969553 3098C FUNCTION : CALL MIRAZ(LENGTH,ITAB)
7fd59977 3099C ----------
3100C
0d969553 3101C RESET TO ZERO A TABLE OF LOGIC OR INTEGER.
7fd59977 3102C
0d969553 3103C KEYWORDS :
7fd59977 3104C -----------
3105C RAZ INTEGER
3106C
0d969553 3107C INPUT ARGUMENTS :
7fd59977 3108C ------------------
0d969553
Y		 3109C LENGTH : NUMBER OF OCTETS TO TRANSFER
3110C ITAB : NAME OF THE TABLE
7fd59977 3111C
0d969553
Y		 3112C OUTPUT ARGUMENTS :
3113C -------------------
3114C ITAB : NAME OF THE TABLE SET TO ZERO
7fd59977 3115C
0d969553 3116C COMMONS USED :
7fd59977 3117C ----------------
3118C
0d969553
Y		 3119C REFERENCES CALLED :
3120C ---------------------
7fd59977 3121C
0d969553 3122C DEMSCRIPTION/NOTES/LIMITATIONS :
7fd59977 3123C -----------------------------------
3124C
3125C Portable VAX-SGI
0d969553 3126
7fd59977 3127C>
3128C***********************************************************************
3129*/
3130//=======================================================================
3131//function : AdvApp2Var_SysBase::miraz_
3132//purpose :
3133//=======================================================================
3134void AdvApp2Var_SysBase::miraz_(integer *taille,
fadcea2c 3135 void *adt)
7fd59977 3136
3137{
3138 integer offset;
3139 offset = *taille;
3140 memset(adt , '\0' , *taille) ;
3141}
3142//=======================================================================
3143//function : AdvApp2Var_SysBase::mnfndeb_
3144//purpose :
3145//=======================================================================
3146integer AdvApp2Var_SysBase::mnfndeb_()
3147{
3148 integer ret_val;
3149 ret_val = 0;
3150 return ret_val;
3151} /* mnfndeb_ */
3152
3153//=======================================================================
3154//function : AdvApp2Var_SysBase::mnfnimp_
3155//purpose :
3156//=======================================================================
3157integer AdvApp2Var_SysBase::mnfnimp_()
3158{
3159 integer ret_val;
3160 ret_val = 6;
3161 return ret_val;
3162} /* mnfnimp_ */
3163
3164//=======================================================================
3165//function : AdvApp2Var_SysBase::msifill_
3166//purpose :
3167//=======================================================================
3168int AdvApp2Var_SysBase::msifill_(integer *nbintg,
3169 integer *ivecin,
3170 integer *ivecou)
3171{
1ef32e96 3172 integer nocte;
7fd59977 3173
3174/* ***********************************************************************
3175 */
3176
0d969553 3177/* FUNCTION : */
7fd59977 3178/* ---------- */
0d969553 3179/* transfer Integer from one zone to another */
7fd59977 3180
0d969553 3181/* KEYWORDS : */
7fd59977 3182/* ----------- */
0d969553 3183/* TRANSFER , INTEGER , MEMORY */
7fd59977 3184
0d969553 3185/* INPUT ARGUMENTS : */
7fd59977 3186/* ------------------ */
0d969553
Y		 3187/* NBINTG : Nb of integers */
3188/* IVECIN : Input vector */
7fd59977 3189
0d969553 3190/* OUTPUT ARGUMENTS : */
7fd59977 3191/* ------------------- */
0d969553 3192/* IVECOU : Output vector */
7fd59977 3193
0d969553 3194/* COMMONS USED : */
7fd59977 3195/* ---------------- */
3196
0d969553
Y		 3197/* REFERENCES CALLED : */
3198/* --------------------- */
7fd59977 3199
0d969553 3200/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 3201/* ----------------------------------- */
3202
7fd59977 3203/* > */
3204/* ***********************************************************************
3205 */
3206
0d969553 3207/* ___ NOCTE : Number of octets to transfer */
7fd59977 3208
3209 /* Parameter adjustments */
3210 --ivecou;
3211 --ivecin;
3212
3213 /* Function Body */
3214 nocte = *nbintg * sizeof(integer);
fadcea2c 3215 AdvApp2Var_SysBase::mcrfill_(&nocte, &ivecin[1], &ivecou[1]);
7fd59977 3216 return 0 ;
3217} /* msifill_ */
3218
3219//=======================================================================
3220//function : AdvApp2Var_SysBase::msrfill_
3221//purpose :
3222//=======================================================================
3223int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
3224 doublereal *vecent,
3225 doublereal * vecsor)
3226{
1ef32e96 3227 integer nocte;
7fd59977 3228
3229
3230/* ***********************************************************************
3231 */
3232
3233/* FONCTION : */
3234/* ---------- */
0d969553 3235/* Transfer real from one zone to another */
7fd59977 3236
0d969553 3237/* KEYWORDS : */
7fd59977 3238/* ----------- */
0d969553 3239/* TRANSFER , REAL , MEMORY */
7fd59977 3240
0d969553
Y		 3241/* INPUT ARGUMENTS : */
3242/* ----------------- */
3243/* NBREEL : Number of reals */
3244/* VECENT : Input vector */
7fd59977 3245
0d969553 3246/* OUTPUT ARGUMENTS : */
7fd59977 3247/* ------------------- */
0d969553 3248/* VECSOR : Output vector */
7fd59977 3249
0d969553 3250/* COMMONS USED : */
7fd59977 3251/* ---------------- */
3252
0d969553 3253/* REFERENCES CALLED : */
7fd59977 3254/* ----------------------- */
3255
0d969553 3256/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 3257/* ----------------------------------- */
3258
7fd59977 3259/* > */
3260/* ***********************************************************************
3261 */
3262
0d969553 3263/* ___ NOCTE : Nb of octets to transfer */
7fd59977 3264
3265 /* Parameter adjustments */
3266 --vecsor;
3267 --vecent;
3268
3269 /* Function Body */
fadcea2c
RL		 3270 nocte = *nbreel * sizeof (doublereal);
3271 AdvApp2Var_SysBase::mcrfill_(&nocte, &vecent[1], &vecsor[1]);
7fd59977 3272 return 0 ;
3273} /* msrfill_ */
3274
3275//=======================================================================
3276//function : AdvApp2Var_SysBase::mswrdbg_
3277//purpose :
3278//=======================================================================
3279int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
3280 ftnlen )//ctexte_len)
3281
3282{
3283
1ef32e96 3284 cilist io___1 = { 0, 0, 0, 0, 0 };
7fd59977 3285
3286
3287/* ***********************************************************************
3288 */
3289
0d969553 3290/* FUNCTION : */
7fd59977 3291/* ---------- */
0d969553 3292/* Write message on console alpha if IBB>0 */
7fd59977 3293
0d969553 3294/* KEYWORDS : */
7fd59977 3295/* ----------- */
0d969553 3296/* MESSAGE, DEBUG */
7fd59977 3297
0d969553
Y		 3298/* INPUT ARGUMENTS : */
3299/* ----------------- */
3300/* CTEXTE : Text to be written */
7fd59977 3301
0d969553 3302/* OUTPUT ARGUMENTS : */
7fd59977 3303/* ------------------- */
0d969553 3304/* None */
7fd59977 3305
0d969553 3306/* COMMONS USED : */
7fd59977 3307/* ---------------- */
3308
0d969553 3309/* REFERENCES CALLED : */
7fd59977 3310/* ----------------------- */
3311
0d969553 3312/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 3313/* ----------------------------------- */
3314
0d969553 3315
7fd59977 3316/* > */
3317/* ***********************************************************************
3318 */
3319/* DECLARATIONS */
3320/* ***********************************************************************
3321 */
3322
3323
3324/* ***********************************************************************
3325 */
0d969553 3326/* PROCESSING */
7fd59977 3327/* ***********************************************************************
3328 */
3329
3330 if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
3331 io___1.ciunit = AdvApp2Var_SysBase::mnfnimp_();
3332 //s__wsle(&io___1);
3333 //do__lio(&c__9, &c__1, "Dbg ", 4L);
3334 //do__lio(&c__9, &c__1, ctexte, ctexte_len);
3335 AdvApp2Var_SysBase::e__wsle();
3336 }
3337 return 0 ;
3338} /* mswrdbg_ */
3339
3340
3341
3342int __i__len()
3343{
3344 return 0;
3345}
3346
3347int __s__cmp()
3348{
3349 return 0;
3350}
3351
3352//=======================================================================
3353//function : do__fio
3354//purpose :
3355//=======================================================================
3356int AdvApp2Var_SysBase::do__fio()
3357{
3358return 0;
3359}
3360//=======================================================================
3361//function : do__lio
3362//purpose :
3363//=======================================================================
3364int AdvApp2Var_SysBase::do__lio ()
3365{
3366 return 0;
3367}
3368//=======================================================================
3369//function : e__wsfe
3370//purpose :
3371//=======================================================================
3372int AdvApp2Var_SysBase::e__wsfe ()
3373{
3374 return 0;
3375}
3376//=======================================================================
3377//function : e__wsle
3378//purpose :
3379//=======================================================================
3380int AdvApp2Var_SysBase::e__wsle ()
3381{
3382 return 0;
3383}
3384//=======================================================================
3385//function : s__wsfe
3386//purpose :
3387//=======================================================================
3388int AdvApp2Var_SysBase::s__wsfe ()
3389{
3390 return 0;
3391}
3392//=======================================================================
3393//function : s__wsle
3394//purpose :
3395//=======================================================================
3396int AdvApp2Var_SysBase::s__wsle ()
3397{
3398 return 0;
3399}
3400
3401
3402/*
3403C*****************************************************************************
3404C
0d969553 3405C FUNCTION : CALL MVRIRAZ(NBELT,DTAB)
7fd59977 3406C ----------
0d969553 3407C Reset to zero a table with DOUBLE PRECISION
7fd59977 3408C
0d969553 3409C KEYWORDS :
7fd59977 3410C -----------
3411C MVRMIRAZ DOUBLE
3412C
0d969553 3413C INPUT ARGUMENTS :
7fd59977 3414C ------------------
0d969553
Y		 3415C NBELT : Number of elements of the table
3416C DTAB : Table to initializer to zero
7fd59977 3417C
0d969553 3418C OUTPUT ARGUMENTS :
7fd59977 3419C --------------------
0d969553 3420C DTAB : Table reset to zero
7fd59977 3421C
0d969553 3422C COMMONS USED :
7fd59977 3423C ----------------
3424C
0d969553 3425C REFERENCES CALLED :
7fd59977 3426C -----------------------
3427C
0d969553 3428C DEMSCRIPTION/NOTES/LIMITATIONS :
7fd59977 3429C -----------------------------------
0d969553 3430C
7fd59977 3431C
3432C>
3433C***********************************************************************
3434*/
3435//=======================================================================
3436//function : AdvApp2Var_SysBase::mvriraz_
3437//purpose :
3438//=======================================================================
3439void AdvApp2Var_SysBase::mvriraz_(integer *taille,
fadcea2c 3440 void *adt)
7fd59977 3441
3442{
3443 integer offset;
3444 offset = *taille * 8 ;
3445 /* printf(" adt %d long %d\n",adt,offset); */
3446 memset(adt , '\0' , offset) ;
3447}
Open CASCADE Technology repository