src/AdvApp2Var/AdvApp2Var_SysBase.cxx

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