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