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