src/AdvApp2Var/AdvApp2Var_SysBase.cxx

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