src/AdvApp2Var/AdvApp2Var_SysBase.cxx

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