OpenCascade/occt
1
0
Fork 0
mirror of https://git.dev.opencascade.org/repos/occt.git synced 2025-04-03 17:56:21 +03:00
Code Packages Releases Activity
occt/src/AdvApp2Var/AdvApp2Var_SysBase.cxx
kgv 73dee81133 0032460: Coding Rules - eliminate CLang warning -Wunused-but-set-variable 
Code has been adjusted to suppress -Wunused-but-set-variable warnings.

DRAWEXE.wasm, compiler flags have been moved to linker flags
to eliminiate -Wunused-command-line-argument warnings.
2021-06-24 23:47:45 +03:00

3348 lines
90 KiB
C++
Raw Blame History

// Copyright (c) 1999-2014 OPEN CASCADE SAS
//
// This file is part of Open CASCADE Technology software library.
//
// This library is free software; you can redistribute it and/or modify it under
// the terms of the GNU Lesser General Public License version 2.1 as published
// by the Free Software Foundation, with special exception defined in the file
// OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
// distribution for complete text of the license and disclaimer of any warranty.
//
// Alternatively, this file may be used under the terms of Open CASCADE
// commercial license or contractual agreement.
// AdvApp2Var_SysBase.cxx
#include <assert.h>
#include <cmath>
#include <stdlib.h>
#include <string.h>
#include <AdvApp2Var_Data_f2c.hxx>
#include <AdvApp2Var_SysBase.hxx>
#include <AdvApp2Var_Data.hxx>
#include <Standard.hxx>
static
int __i__len();
static
int __s__cmp();
static
int macrbrk_();
static
int macrclw_(intptr_t *iadfld,
intptr_t *iadflf,
integer *nalloc);
static
int macrerr_(intptr_t *iad,
intptr_t *nalloc);
static
int macrgfl_(intptr_t *iadfld,
intptr_t *iadflf,
integer *iphase,
integer *iznuti);
static
int macrmsg_(const char *crout,
integer *num,
integer *it,
doublereal *xt,
const char *ct,
ftnlen crout_len,
ftnlen ct_len);
static
int macrstw_(intptr_t *iadfld,
intptr_t *iadflf,
integer *nalloc);
static
int madbtbk_(integer *indice);
static
int magtlog_(const char *cnmlog,
const char *chaine,
integer *long__,
integer *iercod,
ftnlen cnmlog_len,
ftnlen chaine_len);
static
int mamdlng_(char *cmdlng,
ftnlen cmdlng_len);
static
int maostrb_();
static
int maostrd_();
static
int maoverf_(integer *nbentr,
doublereal *dtable);
static
int matrlog_(const char *cnmlog,
const char *chaine,
integer *length,
integer *iercod,
ftnlen cnmlog_len,
ftnlen chaine_len);
static
int matrsym_(const char *cnmsym,
const char *chaine,
integer *length,
integer *iercod,
ftnlen cnmsym_len,
ftnlen chaine_len);
static
int mcrcomm_(integer *kop,
integer *noct,
intptr_t *iadr,
integer *ier);
static
int mcrfree_(integer *ibyte,
intptr_t iadr,
integer *ier);
static
int mcrgetv_(integer *sz,
intptr_t *iad,
integer *ier);
static
int mcrlocv_(void* t,
intptr_t *l);
static struct {
integer lec, imp, keyb, mae, jscrn, itblt, ibb;
} mblank__;
#define mcrfill_ABS(a) (((a)<0)?(-(a)):(a))
//=======================================================================
//function : AdvApp2Var_SysBase
//purpose :
//=======================================================================
AdvApp2Var_SysBase::AdvApp2Var_SysBase()
{
mainial_();
memset (&mcrstac_, 0, sizeof (mcrstac_));
}
//=======================================================================
//function : ~AdvApp2Var_SysBase
//purpose :
//=======================================================================
AdvApp2Var_SysBase::~AdvApp2Var_SysBase()
{
assert (mcrgene_.ncore == 0); //otherwise memory leaking
}
//=======================================================================
//function : macinit_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::macinit_(integer *imode,
integer *ival)
{
/* ************************************************************************/
/* FUNCTION : */
/* ---------- */
/* INITIALIZATION OF READING WRITING UNITS AND 'IBB' */
/* KEYWORDS : */
/* ----------- */
/* MANAGEMENT, CONFIGURATION, UNITS, INITIALIZATION */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* IMODE : MODE of INITIALIZATION :
0= DEFAULT, IMP IS 6, IBB 0 and LEC 5 */
/* 1= FORCE VALUE OF IMP */
/* 2= FORCE VALUE OF IBB */
/* 3= FORCE VALUE OF LEC */
/* ARGUMENT USED ONLY WHEN IMODE IS 1 OR 2 : */
/* IVAL : VALUE OF IMP WHEN IMODE IS 1 */
/* VALUE OF IBB WHEN IMODE IS 2 */
/* VALUE OF LEC WHEN IMODE IS 3 */
/* THERE IS NO CONTROL OF VALIDITY OF VALUE OF IVAL . */
/* OUTPUT ARGUMENTS : */
/* -------------------- */
/* NONE */
/* COMMONS USED : */
/* -------------- */
/* REFERENCES CALLED : */
/* ------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* THIS IS ONLY INITIALIZATION OF THE COMMON BLANK FOR ALL */
/* MODULES THAT A PRIORI DO NOT NEED TO KNOW THE COMMONS OF T . */
/* WHEN A MODIFICATION OF IBB IS REQUIRED (IMODE=2) AN INFO MESSAGE */
/* IS SUBMITTED ON IMP, WITH THE NEW VALUE OF IBB. */
/* IBB : MODE DEBUG OF STRIM T : RULES OF USE : */
/* 0 RESTRAINED VERSION */
/* >0 THE GREATER IS IBB THE MORE COMMENTS THE VERSION HAS. */
/* FOR EXAMPLE FOR IBB=1 THE ROUTINES CALLED */
/* INFORM ON IMP ('INPUT IN TOTO', */
/* AND 'OUTPUT FROM TOTO'), AND THE ROUTINES THAT RETURN */
/* NON NULL ERROR CODE INFORM IT AS WELL. */
/* (BUT IT IS NOT TRUE FOR ALL ROUTINES OF T) */
/* > */
/* ***********************************************************************
*/
if (*imode == 0) {
mblank__.imp = 6;
mblank__.ibb = 0;
mblank__.lec = 5;
} else if (*imode == 1) {
mblank__.imp = *ival;
} else if (*imode == 2) {
mblank__.ibb = *ival;
} else if (*imode == 3) {
mblank__.lec = *ival;
}
/* ----------------------------------------------------------------------*
*/
return 0;
} /* macinit__ */
//=======================================================================
//function : macrai4_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
integer *maxelm,
integer *itablo,
intptr_t *iofset,
integer *iercod)
{
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Require dynamic allocation of type INTEGER */
/* KEYWORDS : */
/* ---------- */
/* SYSTEM, ALLOCATION, MEMORY, REALISATION */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* NBELEM : Number of required units */
/* MAXELM : Max number of units available in ITABLO */
/* ITABLO : Reference Address of the rented zone */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* IOFSET : Offset */
/* IERCOD : Error code */
/* = 0 : OK */
/* = 1 : Max nb of allocations attained */
/* = 2 : Incorrect arguments */
/* = 3 : Refused dynamic allocation */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* MCRRQST */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* (Cf description in the heading of MCRRQST) */
/* Table ITABLO should be dimensioned to MAXELM by the caller. */
/* If the request is lower or equal to MAXELM, IOFSET becomes = 0. */
/* Otherwise the demand of allocation is valid and IOFSET > 0. */
/* > */
/* ***********************************************************************
*/
integer iunit;
iunit = sizeof(integer);
/* Function Body */
if (*nbelem > *maxelm) {
/*AdvApp2Var_SysBase::*/mcrrqst_(&iunit, nbelem, itablo, iofset, iercod);
} else {
*iercod = 0;
*iofset = 0;
}
return 0 ;
} /* macrai4_ */
//=======================================================================
//function : AdvApp2Var_SysBase::macrar8_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
integer *maxelm,
doublereal *xtablo,
intptr_t *iofset,
integer *iercod)
{
integer c__8 = 8;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Demand of dynamic allocation of type DOUBLE PRECISION */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, REALISATION */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NBELEM : Nb of units required */
/* MAXELM : Max Nb of units available in XTABLO */
/* XTABLO : Reference address of the rented zone */
/* OUTPUT ARGUMENTS : */
/* ------------------ */
/* IOFSET : Offset */
/* IERCOD : Error code */
/* = 0 : OK */
/* = 1 : Max Nb of allocations reached */
/* = 2 : Arguments incorrect */
/* = 3 : Refuse of dynamic allocation */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* MCRRQST */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* (Cf description in the heading of MCRRQST) */
/* Table XTABLO should be dimensioned to MAXELM by the caller. */
/* If the request is less or equal to MAXELM, IOFSET becomes = 0. */
/* Otherwise the demand of allocation is valid and IOFSET > 0. */
/* > */
/* ***********************************************************************
*/
/* Function Body */
if (*nbelem > *maxelm) {
/*AdvApp2Var_SysBase::*/mcrrqst_(&c__8, nbelem, xtablo, iofset, iercod);
} else {
*iercod = 0;
*iofset = 0;
}
return 0 ;
} /* macrar8_ */
//=======================================================================
//function : macrbrk_
//purpose :
//=======================================================================
int macrbrk_()
{
return 0 ;
} /* macrbrk_ */
//=======================================================================
//function : macrchk_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::macrchk_()
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, j;
intptr_t ioff;
doublereal* t = 0;
intptr_t loc;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* CONTROL OF EXCESSES OF ALLOCATED MEMORY ZONE */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, CONTROL, EXCESS */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* NONE */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* NONE */
/* COMMONS USED : */
/* ------------------ */
/* MCRGENE */
/* REFERENCES CALLED : */
/* --------------------- */
/* MACRERR, MAOSTRD */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ***********************************************************************
*/
/* FONCTION : */
/* ---------- */
/* TABLE OF MANAGEMENT OF DYNAMIC MEMOTY ALLOCATIONS */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, MEMORY, ALLOCATION */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
/* 2 : UNIT OF ALLOCATION */
/* 3 : NB OF ALLOCATED UNITS */
/* 4 : REFERENCE ADDRESS OF THE TABLE */
/* 5 : IOFSET */
/* 6 : STATIC ALLOCATION NUMBER */
/* 7 : Required allocation size */
/* 8 : address of the beginning of allocation */
/* 9 : Size of the USER ZONE */
/* 10 : ADDRESS of the START FLAG */
/* 11 : ADDRESS of the END FLAG */
/* 12 : Rank of creation of the allocation */
/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
/* NCORE : NB OF CURRENT ALLOCS */
/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
/* ----------------------------------------------------------------------*
*/
/* ----------------------------------------------------------------------*
*/
/* CALCULATE ADDRESS OF T */
mcrlocv_(t, &loc);
/* CONTROL OF FLAGS IN THE TABLE */
i__1 = mcrgene_.ncore;
for (i__ = 0; i__ < i__1; ++i__) {
//p to access startaddr and endaddr
intptr_t* p = &mcrgene_.icore[i__].startaddr;
for (j = 0; j <= 1; ++j) {
intptr_t* pp = p + j;
if (*pp != -1) {
ioff = (*pp - loc) / 8;
if (t[ioff] != -134744073.) {
/* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS
E:',ICORE(J,I) */
/* AND OF RANK ICORE(12,I) */
macrerr_(pp, p + 2);
/* BACK-PARCING IN PHASE OF PRODUCTION */
maostrb_();
/* REMOVAL OF THE ADDRESS OF FLAG TO AVOID REMAKING ITS CONTROL */
*pp = -1;
}
}
/* L100: */
}
/* L1000: */
}
return 0 ;
} /* macrchk_ */
//=======================================================================
//function : macrclw_
//purpose :
//=======================================================================
int macrclw_(intptr_t *,//iadfld,
intptr_t *,//iadflf,
integer *)//nalloc)
{
return 0 ;
} /* macrclw_ */
//=======================================================================
//function : AdvApp2Var_SysBase::macrdi4_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::macrdi4_(integer *nbelem,
integer *,//maxelm,
integer *itablo,
intptr_t *iofset, /* Offset long (pmn) */
integer *iercod)
{
/* ***********************************************************************
*/
/* FuNCTION : */
/* ---------- */
/* Destruction of dynamic allocation of type INTEGER */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NBELEM : Nb of units required */
/* MAXELM : Max Nb of units available in ITABLO */
/* ITABLO : Reference Address of the allocated zone */
/* IOFSET : Offset */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* IERCOD : Error Code */
/* = 0 : OK */
/* = 1 : Pb of de-allocation of a zone allocated in table */
/* = 2 : The system refuses the demand of de-allocation */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* MCRDELT */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* (Cf description in the heading of MCRDELT) */
/* > */
/* ***********************************************************************
*/
integer iunit;
iunit = sizeof(integer);
/* Function Body */
if (*iofset != 0) {
AdvApp2Var_SysBase::mcrdelt_(&iunit,
nbelem,
itablo,
iofset,
iercod);
} else {
*iercod = 0;
}
return 0 ;
} /* macrdi4_ */
//=======================================================================
//function : AdvApp2Var_SysBase::macrdr8_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
integer *,//maxelm,
doublereal *xtablo,
intptr_t *iofset,
integer *iercod)
{
integer c__8 = 8;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Destruction of dynamic allocation of type DOUBLE PRECISION
*/
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* NBELEM : Nb of units required */
/* MAXELM : Max nb of units available in XTABLO */
/* XTABLO : Reference Address of the allocated zone */
/* IOFSET : Offset */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* IERCOD : Error Code */
/* = 0 : OK */
/* = 1 : Pb of de-allocation of a zone allocated on table */
/* = 2 : The system refuses the demand of de-allocation */
/* COMMONS USED : */
/* -------------- */
/* REFERENCES CALLEDS : */
/* -------------------- */
/* MCRDELT */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* (Cf description in the heading of MCRDELT) */
/* > */
/* ***********************************************************************
*/
/* Function Body */
if (*iofset != 0) {
AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, xtablo, iofset, iercod);
} else {
*iercod = 0;
}
return 0 ;
} /* macrdr8_ */
//=======================================================================
//function : macrerr_
//purpose :
//=======================================================================
int macrerr_(intptr_t *,//iad,
intptr_t *)//nalloc)
{
//integer c__1 = 1;
/* Builtin functions */
//integer /*do__fio(),*/;
/* Fortran I/O blocks */
//cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* WRITING OF ADDRESS REMOVED IN ALLOCS . */
/* KEYWORDS : */
/* ----------- */
/* ALLOC CONTROL */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* IAD : ADDRESS TO INFORM OF REMOVAL */
/* NALLOC : NUMBER OF ALLOCATION */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* NONE */
/* COMMONS USED : */
/* -------------- */
/* REFERENCES CALLED : */
/* ------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/*
do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
do__fio(&c__1, " sur l'allocation ", 18L);
do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
*/
return 0 ;
} /* macrerr_ */
//=======================================================================
//function : macrgfl_
//purpose :
//=======================================================================
int macrgfl_(intptr_t *iadfld,
intptr_t *iadflf,
integer *iphase,
integer *iznuti)
{
/* Initialized data */
/* original code used static integer ifois=0 which served as static
initialization flag and was only used to call matrsym_() once; now
this flag is not used as matrsym_() always returns 0 and has no
useful contents
*/
integer ifois = 1;
char cbid[1] = {};
integer ibid, ienr;
doublereal* t = 0;
integer novfl = 0;
intptr_t ioff,iadt;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* IMPLEMENTATION OF TWO FLAGS START AND END OF THE ALLOCATED ZONE */
/* AND SETTING TO OVERFLOW OF THE USER SPACE IN PHASE OF PRODUCTION. */
/* KEYWORDS : */
/* ----------- */
/* ALLOCATION, CONTROL, EXCESS */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* IADFLD : ADDRESS OF THE START FLAG */
/* IADFLF : ADDRESS OF THE END FLAG */
/* IPHASE : TYPE OF SOFTWARE VERSION : */
/* 0 = OFFICIAL VERSION */
/* 1 = PRODUCTION VERSION */
/* IZNUTI : SIZE OF THE USER ZONE IN OCTETS */
/* OUTPUT ARGUMENTS : */
/* ------------------ */
/* NONE */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* ------------------- */
/* CRLOCT,MACRCHK */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* TABLE FOR MANAGEMENT OF DYNAMIC ALLOCATIONS OF MEMORY */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, MEMORY, ALLOCATION */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
/* 2 : UNIT OF ALLOCATION */
/* 3 : NB OF ALLOCATED UNITS */
/* 4 : REFERENCE ADDRESS OF THE TABLE */
/* 5 : IOFSET */
/* 6 : STATIC ALLOCATION NUMBER */
/* 7 : Required allocation size */
/* 8 : address of the beginning of allocation */
/* 9 : Size of the USER ZONE */
/* 10 : ADDRESS of the START FLAG */
/* 11 : ADDRESS of the END FLAG */
/* 12 : Rank of creation of the allocation */
/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
/* NCORE : NB OF CURRENT ALLOCS */
/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
/* ----------------------------------------------------------------------*
*/
if (ifois == 0) {
matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
ifois = 1;
}
/* CALCULATE THE ADDRESS OF T */
mcrlocv_(t, &iadt);
/* CALCULATE THE OFFSET */
ioff = (*iadfld - iadt) / 8;
/* SET TO OVERFLOW OF THE USER ZONE IN CASE OF PRODUCTION VERSION */
if (*iphase == 1 && novfl == 0) {
ienr = *iznuti / 8;
maoverf_(&ienr, &t[ioff + 1]);
}
/* UPDATE THE START FLAG */
t[ioff] = -134744073.;
/* FAKE CALL TO STOP THE DEBUGGER : */
macrbrk_();
/* UPDATE THE START FLAG */
ioff = (*iadflf - iadt) / 8;
t[ioff] = -134744073.;
/* FAKE CALL TO STOP THE DEBUGGER : */
macrbrk_();
return 0 ;
} /* macrgfl_ */
//=======================================================================
//function : macrmsg_
//purpose :
//=======================================================================
int macrmsg_(const char *,//crout,
integer *,//num,
integer *it,
doublereal *xt,
const char *ct,
ftnlen ,//crout_len,
ftnlen ct_len)
{
/* Local variables */
integer inum;
char /*cfm[80],*/ cln[3];
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* MESSAGING OF ROUTINES OF ALLOCATION */
/* KEYWORDS : */
/* ----------- */
/* ALLOC, MESSAGE */
/* INPUT ARGUMENTSEE : */
/* ------------------- */
/* CROUT : NAME OF THE CALLING ROUTINE : MCRRQST, MCRDELT, MCRLIST
*/
/* ,CRINCR OR CRPROT */
/* NUM : MESSAGE NUMBER */
/* IT : TABLE OF INTEGER DATA */
/* XT : TABLE OF REAL DATA */
/* CT : ------------------ CHARACTER */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* NONE */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* ROUTINE FOR TEMPORARY USE, WAITING FOR THE 'NEW' MESSAGE */
/* (STRIM 3.3 ?), TO MAKE THE ROUTINES OF ALLOC USABLE */
/* IN STRIM T-M . */
/* DEPENDING ON THE LANGUAGE, WRITING OF THE REQUIRED MESSAGE ON */
/* UNIT IMP . */
/* (REUSE OF SPECIFS OF VFORMA) */
/* THE MESSAGE IS INITIALIZED AT 'MESSAGE MISSING', AND IT IS */
/* REPLACED BY THE REQUIRED MESSAGE IF EXISTS. */
/* > */
/* ***********************************************************************
*/
/* LOCAL : */
/* ----------------------------------------------------------------------*
*/
/* FIND MESSAGE DEPENDING ON THE LANGUAGE , THE ROUTINE */
/* AND THE MESSAGE NUMBER */
/* READING OF THE LANGUAGE : */
/* Parameter adjustments */
ct -= ct_len;
(void )ct; // unused
--xt;
--it;
/* Function Body */
mamdlng_(cln, 3L);
/* INUM : TYPE OF MESSAGE : 0 AS TEXT, 1 1 INTEGER TO BE WRITTEN */
/* -1 MESSAGE INEXISTING (1 INTEGER AND 1 CHAIN) */
inum = -1;
/*
if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
__s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
e de nom : ',A8)", 80L, 71L);
if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
ee(s) : ',I6,/)", 80L, 62L);
} else if (*num == 2) {
inum = 1;
__s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
} else if (*num == 3) {
inum = 1;
__s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
}
} else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 0;
__s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
e pas ')", 80L, 56L);
} else if (*num == 2) {
inum = 0;
__s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
ion de memoire ')", 80L, 65L);
}
} else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
atteint :',I6)", 80L, 62L);
} else if (*num == 2) {
inum = 1;
__s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
40L);
} else if (*num == 3) {
inum = 1;
__s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
de ',I12,' octets')", 80L, 66L);
}
} else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
if (*num == 1) {
inum = 0;
__s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
iste pas')", 80L, 57L);
}
} else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
) : ',I12)", 80L, 57L);
}
}
} else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
__s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
mm des Namens : ',A8)", 80L, 76L);
if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
sung(en) : ',I6,/)", 80L, 65L);
} else if (*num == 2) {
inum = 1;
__s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
} else if (*num == 3) {
inum = 1;
__s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
41L);
}
} else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 0;
__s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
nicht !! ')", 80L, 59L);
} else if (*num == 2) {
inum = 0;
__s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
Zuweisung !!')", 80L, 61L);
}
} else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
icht :',I6)", 80L, 58L);
} else if (*num == 2) {
inum = 1;
__s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
;
} else if (*num == 3) {
inum = 1;
__s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
,I12,' Bytes')", 80L, 61L);
}
} else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
if (*num == 1) {
inum = 0;
__s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
stiert nicht !! ')", 80L, 65L);
}
} else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
: ',I12)", 80L, 55L);
}
}
} else {
__s__copy(cfm, "(' Message number ',I5,' is missing ' \
,'for program named: ',A8)", 80L, 93L);
if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(/,' number of memory allocations carried out: \
',I6,/)", 80L, 54L);
} else if (*num == 2) {
inum = 1;
__s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
} else if (*num == 3) {
inum = 1;
__s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
}
} else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 0;
__s__copy(cfm, "(' Memory allocation to delete does not exist !\
! ')", 80L, 51L);
} else if (*num == 2) {
inum = 0;
__s__copy(cfm, "(' System refuses deletion of memory allocation\
!! ')", 80L, 53L);
}
} else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(' max number of memory allocations reached :',\
I6)", 80L, 50L);
} else if (*num == 2) {
inum = 1;
__s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
40L);
} else if (*num == 3) {
inum = 1;
__s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
' bytes ')", 80L, 57L);
}
} else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
if (*num == 1) {
inum = 0;
__s__copy(cfm, "(' Memory allocation to increment does not exis\
t !! ')", 80L, 54L);
}
} else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
if (*num == 1) {
inum = 1;
__s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
',I12)", 80L, 53L);
}
}
}
*/
/* ----------------------------------------------------------------------*
*/
/* iMPLEMENTATION OF WRITE , WITH OR WITHOUT DATA : */
if (inum == 0) {
} else if (inum == 1) {
/*
do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
*/
} else {
/* MESSAGE DOES NOT EXIST ... */
/*
do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
do__fio(&c__1, crout, crout_len);
*/
}
return 0;
} /* macrmsg_ */
//=======================================================================
//function : macrstw_
//purpose :
//=======================================================================
int macrstw_(intptr_t *,//iadfld,
intptr_t *,//iadflf,
integer *)//nalloc)
{
return 0 ;
} /* macrstw_ */
//=======================================================================
//function : madbtbk_
//purpose :
//=======================================================================
int madbtbk_(integer *indice)
{
*indice = 0;
return 0 ;
} /* madbtbk_ */
//=======================================================================
//function : AdvApp2Var_SysBase::maermsg_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
integer *,//icoder,
ftnlen )//cnompg_len)
{
return 0 ;
} /* maermsg_ */
//=======================================================================
//function : magtlog_
//purpose :
//=======================================================================
int magtlog_(const char *cnmlog,
const char *,//chaine,
integer *long__,
integer *iercod,
ftnlen cnmlog_len,
ftnlen )//chaine_len)
{
/* Local variables */
char cbid[255];
integer ibid, ier;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* RETURN TRANSLATION OF "NAME LOGIC STRIM" IN */
/* "INTERNAL SYNTAX" CORRESPONDING TO "PLACE OF RANKING" */
/* KEYWORDS : */
/* ----------- */
/* NOM LOGIQUE STRIM , TRADUCTION */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* CNMLOG : NAME OF "NAME LOGIC STRIM" TO TRANSLATE */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* CHAINE : ADDRESS OF "PLACE OF RANKING" */
/* LONG : USEFUL LENGTH OF "PLACE OF RANKING" */
/* IERCOD : ERROR CODE */
/* IERCOD = 0 : OK */
/* IERCOD = 5 : PLACE OF RANKING CORRESPONDING TO INEXISTING LOGIC NAME */
/* IERCOD = 6 : TRANSLATION TOO LONG FOR THE 'CHAIN' VARIABLE */
/* IERCOD = 7 : CRITICAL ERROR */
/* COMMONS USED : */
/* ---------------- */
/* NONE */
/* REFERENCES CALLED : */
/* --------------------- */
/* GNMLOG, MACHDIM */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* SPECIFIC SGI ROUTINE */
/* IN ALL CASES WHEN IERCOD IS >0, NO RESULT IS RETURNED*/
/* NOTION OF "USER SYNTAX' AND "INTERNAL SYNTAX" */
/* --------------------------------------------------- */
/* THE "USER SYNTAX" IS THE SYNTAX WHERE THE USER*/
/* VISUALIZES OR INDICATES THE FILE OR DIRECTORY NAME */
/* DURING A SESSION OF STRIM100 */
/* "INTERNAL SYNTAX" IS SYNTAX USED TO CARRY OUT */
/* OPERATIONS OF FILE PROCESSING INSIDE THE CODE */
/* (OPEN,INQUIRE,...ETC) */
/* > */
/* ***********************************************************************
*/
/* DECLARATIONS */
/* ***********************************************************************
*/
/* ***********************************************************************
*/
/* PROCESSING */
/* ***********************************************************************
*/
*long__ = 0;
*iercod = 0;
/* CONTROL OF EXISTENCE OF THE LOGIC NAME */
matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
if (ier == 1) {
goto L9500;
}
if (ier == 2) {
goto L9700;
}
/* CONTROL OF THE LENGTH OF CHAIN */
if (ibid > __i__len()/*chaine, chaine_len)*/) {
goto L9600;
}
//__s__copy(chaine, cbid, chaine_len, ibid);
*long__ = ibid;
goto L9999;
/* ***********************************************************************
*/
/* ERROR PROCESSING */
/* ***********************************************************************
*/
L9500:
*iercod = 5;
//__s__copy(chaine, " ", chaine_len, 1L);
goto L9999;
L9600:
*iercod = 6;
//__s__copy(chaine, " ", chaine_len, 1L);
goto L9999;
L9700:
*iercod = 7;
//__s__copy(chaine, " ", chaine_len, 1L);
/* ***********************************************************************
*/
/* RETURN TO THE CALLING PROGRAM */
/* ***********************************************************************
*/
L9999:
return 0;
} /* magtlog_ */
//=======================================================================
//function : mainial_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mainial_()
{
mcrgene_.ncore = 0;
mcrgene_.lprot = 0;
return 0 ;
} /* mainial_ */
//=======================================================================
//function : AdvApp2Var_SysBase::maitbr8_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::maitbr8_(integer *itaill,
doublereal *xtab,
doublereal *xval)
{
integer c__504 = 504;
/* Initialized data */
doublereal buff0[63] = {
0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
0.,0.,0.,0.,0.
};
/* System generated locals */
integer i__1;
/* Local variables */
integer i__;
doublereal buffx[63];
integer nbfois, noffst, nreste, nufois;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* INITIALIZATION TO A GIVEN VALUE OF A TABLE OF REAL *8 */
/* KEYWORDS : */
/* ----------- */
/* MANIPULATIONS, MEMORY, INITIALIZATION, DOUBLE-PRECISION */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* ITAILL : SIZE OF THE TABLE */
/* XTAB : TABLE TO INITIALIZE WITH XVAL */
/* XVAL : VALUE TO SET IN XTAB(FROM 1 TO ITAILL) */
/* OUTPUT ARGUMENTS : */
/* ------------------ */
/* XTAB : INITIALIZED TABLE */
/* COMMONS USED : */
/* -------------- */
/* REFERENCES CALLED : */
/* ------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* ONE CALLS MCRFILL WHICH MOVES BY PACKS OF 63 REALS */
/* THE INITIAL PACK IS BUFF0 INITIATED BY DATA IF THE VALUE IS 0 */
/* OR OTHERWISE BUFFX INITIATED BY XVAL (LOOP). */
/* PORTABILITY : YES */
/* ACCESS : FREE */
/* > */
/* ***********************************************************************
*/
/* Parameter adjustments */
--xtab;
/* Function Body */
/* ----------------------------------------------------------------------*
*/
nbfois = *itaill / 63;
noffst = nbfois * 63;
nreste = *itaill - noffst;
if (*xval == 0.) {
if (nbfois >= 1) {
i__1 = nbfois;
for (nufois = 1; nufois <= i__1; ++nufois) {
AdvApp2Var_SysBase::mcrfill_(&c__504, buff0, &xtab[(nufois - 1) * 63 + 1]);
/* L1000: */
}
}
if (nreste >= 1) {
i__1 = nreste << 3;
AdvApp2Var_SysBase::mcrfill_(&i__1, buff0, &xtab[noffst + 1]);
}
} else {
for (i__ = 1; i__ <= 63; ++i__) {
buffx[i__ - 1] = *xval;
/* L2000: */
}
if (nbfois >= 1) {
i__1 = nbfois;
for (nufois = 1; nufois <= i__1; ++nufois) {
AdvApp2Var_SysBase::mcrfill_(&c__504, buffx, &xtab[(nufois - 1) * 63 + 1]);
/* L3000: */
}
}
if (nreste >= 1) {
i__1 = nreste << 3;
AdvApp2Var_SysBase::mcrfill_(&i__1, buffx, &xtab[noffst + 1]);
}
}
/* ----------------------------------------------------------------------*
*/
return 0;
} /* maitbr8_ */
//=======================================================================
//function : mamdlng_
//purpose :
//=======================================================================
int mamdlng_(char *,//cmdlng,
ftnlen )//cmdlng_len)
{
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* RETURN THE CURRENT LANGUAGE */
/* KEYWORDS : */
/* ----------- */
/* MANAGEMENT, CONFIGURATION, LANGUAGE, READING */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* CMDLNG : LANGUAGE */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* NONE */
/* COMMONS USED : */
/* ------------------ */
/* MACETAT */
/* REFERENCES CALLED : */
/* --------------------- */
/* NONE */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* RIGHT OF USAGE : ANY APPLICATION */
/* ATTENTION : THIS ROUTINE DEPENDS ON PRELIMINARY INITIALISATION */
/* ---------- WITH AMDGEN. */
/* SO IT IS ENOUGH TO PROVIDE THAT THIS INIT IS */
/* CORRECTLY IMPLEMENTED IN THE RESPECTIVE PROGRAMS */
/* > */
/* ***********************************************************************
*/
/* INCLUDE MACETAT */
/* < */
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* CONTAINS INFORMATION ABOUT THE COMPOSITION OF */
/* THE EXECUTABLE AND ITS ENVIRONMENT : */
/* - LANGUAGES */
/* - PRESENT APPLICATIONS */
/* - AUTHORIZED TYPES OF ENTITIES (NON USED) */
/* AND INFORMATION DESCRIBING THE CURRENT STATE : */
/* - CURRENT APPLICATION */
/* - MODE OF USAGE (NOT USED) */
/* KEYWORDS : */
/* ----------- */
/* APPLICATION, LANGUAGE */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* A) CHLANG*4 : LIST OF POSSIBLE VALUES OF THE LANGUAGE : */
/* 'FRA ','DEU ','ENG ' */
/* CHL10N*4 : LIST OF POSSIBLE VALUES OF THE LOCALIZATION : */
/* 'FRA ','DEU ','ENG ', 'JIS ' */
/* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : CURRENT, PREVIOUS AND NEXT APPLICATION */
/* C) CHMODE*4 : CURRENT MODE (NOT USED) */
/* D) CHPRES*2 (1:NBRMOD) : LIST OF APPLICATIONS TAKEN INTO ACCOUNT */
/* Rang ! Code interne ! Application */
/* ---------------------------------------------------------- */
/* 1 ! CD ! Modeling 2D */
/* 2 ! CA ! Modeling 2D by learning */
/* 3 ! CP ! Parameterized 2D modelization */
/* 4 ! PC ! Rheological 2D modelization */
/* 5 ! CU ! Milling 2 Axes 1/2 */
/* 6 ! CT ! Turning */
/* 7 ! TS ! 3D surface modeling */
/* 8 ! TV ! 3D volume modeling */
/* 9 ! MC ! Surface Meshing */
/* 10 ! MV ! Volume Meshing */
/* 11 ! TU ! Machining by 3 axes */
/* 12 ! T5 ! Machining by 3-5 axes */
/* 13 ! TR ! Machinning by 5 axes of regular surfaces */
/* 14 ! IG ! Interface IGES */
/* 15 ! ST ! Interface SET */
/* 16 ! VD ! Interface VDA */
/* 17 ! IM ! Interface of modeling */
/* 18 ! GA ! Generator APT/IFAPT */
/* 19 ! GC ! Generator COMPACT II */
/* 20 ! GP ! Generator PROMO */
/* 21 ! TN ! Machining by numerical copying */
/* 22 ! GM ! Management of models */
/* 23 ! GT ! Management of trace */
/* ---------------------------------------------------------- */
/* > */
/* ***********************************************************************
*/
/* NUMBER OF APPLICATIONS TAKEN INTO ACCOUNT */
/* NUMBER OF ENTITY TYPES MANAGED BY STRIM 100 */
//__s__copy(cmdlng, macetat_.chlang, cmdlng_len, 4L);
return 0 ;
} /* mamdlng_ */
//=======================================================================
//function : maostrb_
//purpose :
//=======================================================================
int maostrb_()
{
return 0 ;
} /* maostrb_ */
//=======================================================================
//function : maostrd_
//purpose :
//=======================================================================
int maostrd_()
{
integer imod;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* REFINE TRACE-BACK IN PRODUCTION PHASE */
/* KEYWORDS : */
/* ----------- */
/* FUNCTION, SYSTEM, TRACE-BACK, REFINING, DEBUG */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* NONE */
/* OUTPUT ARGUMENTS E : */
/* -------------------- */
/* NONE */
/* COMMONS USED : */
/* -------------- */
/* NONE */
/* REFERENCES CALLED : */
/* ------------------- */
/* MADBTBK */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* THIS ROUTINE SHOULD BE CALLED TO REFINE */
/* TRACE-BACK IN PRODUCTION PHASE AND LEAVE TO TESTERS THE */
/* POSSIBILITY TO GET TRACE-BACK IN */
/* CLIENT VERSIONS IF ONE OF THE FOLLOWING CONDITIONS IS */
/* VERIFIED : */
/* - EXISTENCE OF SYMBOL 'STRMTRBK' */
/* - EXISTENCE OF FILE 'STRMINIT:STRMTRBK.DAT' */
/* > */
/* ***********************************************************************
*/
madbtbk_(&imod);
if (imod == 1) {
maostrb_();
}
return 0 ;
} /* maostrd_ */
//=======================================================================
//function : maoverf_
//purpose :
//=======================================================================
int maoverf_(integer *nbentr,
doublereal *dtable)
{
/* Initialized data */
integer ifois = 0;
/* System generated locals */
integer i__1;
/* Local variables */
integer ibid;
doublereal buff[63];
integer ioct, indic, nrest, icompt;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Initialisation in overflow of a tableau with DOUBLE PRECISION */
/* KEYWORDS : */
/* ----------- */
/* MANIPULATION, MEMORY, INITIALISATION, OVERFLOW */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* NBENTR : Number of entries in the table */
/* OUTPUT ARGUMENTS : */
/* ------------------ */
/* DATBLE : Table double precision initialized in overflow */
/* COMMONS USED : */
/* ------------------ */
/* R8OVR contained in the include MAOVPAR.INC */
/* REFERENCES CALLED : */
/* --------------------- */
/* MCRFILL */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* 1) Doc. programmer : */
/* This routine initialized to positive overflow a table with */
/* DOUBLE PRECISION. */
/* Other types of tables (INTEGER*2, INTEGER, REAL, ...) */
/* are not managed by the routine. */
/* It is usable in phase of development to detect the */
/* errors of initialization. */
/* In official version, these calls will be inactive. */
/* ACCESs : Agreed with AC. */
/* The routine does not return error code. */
/* Argument NBELEM should be positive. */
/* If it is negative or null, display message "MAOVERF : NBELEM = */
/* valeur_de_NBELEM" and a Trace Back by the call of routine MAOSTRB. */
/* 2) Doc. designer : */
/* The idea is to minimize the number of calls */
/* to the routine of transfer of numeric zones, */
/* ---------- for the reason of performance. */
/* ! buffer ! For this a table of NLONGR */
/* !__________! DOUBLE PRECISIONs is reserved. This buffer is initialized by */
/* <----------> the instruction DATA. The overflow is accessed in a */
/* NLONGR*8 specific COMMON not by a routine as */
/* the initialisation is done by DATA. */
/* * If NBENTR<NLONGR, a part of the buffer is transferred*/
/* DTABLE in DTABLE. */
/* __________ */
/* ! amorce ! * Otherwise, the entire buffer is transferred in DTABLE. */
/* !__________! This initiates it. Then a loop is execute, which at each
*/
/* ! temps 1 ! iteration transfers the part of the already initialized table */
/* !__________! in the one that was not yet initialized. */
/* ! ! The size of the zone transferred by each call to MCRFILL
*/
/* ! temps 2 ! is NLONGR*2**(numero_de_l'iteration). When
*/
/* ! ! the size of the table to be initialized is */
/* !__________! less than the already initialized size, the loop is */
/* ! ! abandoned and thev last transfer is carried out to */
/* ! ! initialize the remaining table, except for the case when the size */
/* ! ! of the table is of type NLONGR*2**K. */
/* ! temps 3 ! */
/* ! ! * NLONGR will be equal to 19200. */
/* ! ! */
/* ! ! */
/* !__________! */
/* ! reste ! */
/* !__________! */
/* > */
/* ***********************************************************************
*/
/* Inclusion of MAOVPAR.INC */
/* CONSTANTS */
/* INCLUDE MAOVPAR */
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* DEFINES SPECIFIC LIMITED VALUES. */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, LIMITS, VALUES, SPECIFIC */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* *** THEY CAN'T BE REMOVED DURING EXECUTION. */
/* *** THE VALUES OF UNDERFLOW AND OVERFLOW CAN'T BE */
/* DEFINED IN DECIMAL VALUES (ERROR OF COMPILATION D_FLOAT) */
/* THEY ARE DEFINED AS HEXADECIMAL VALUES */
/* > */
/* ***********************************************************************
*/
/* DECLARATION OF THE COMMON FOR NUMERIC TYPES */
/* DECLARATION OF THE COMMON FOR CHARACTER TYPES*/
/* LOCAL VARIABLES */
/* TABLES */
/* DATA */
/* Parameter adjustments */
--dtable;
/* Function Body */
/* vJMB R8OVR IS NOT YET initialized, so impossible to use DATA
*/
/* DATA BUFF / NLONGR * R8OVR / */
/* init of BUFF is done only once */
if (ifois == 0) {
for (icompt = 1; icompt <= 63; ++icompt) {
buff[icompt - 1] = maovpar_.r8ovr;
/* L20: */
}
ifois = 1;
}
/* ^JMB */
/* Exception */
if (*nbentr < 63) {
nrest = *nbentr << 3;
AdvApp2Var_SysBase::mcrfill_(&nrest, buff, &dtable[1]);
} else {
/* Start & initialization */
ioct = 504;
AdvApp2Var_SysBase::mcrfill_(&ioct, buff, &dtable[1]);
indic = 63;
/* Loop. The upper limit is the integer value of the logarithm of base 2
*/
/* of NBENTR/NLONGR. */
i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.))
;
for (ibid = 1; ibid <= i__1; ++ibid) {
AdvApp2Var_SysBase::mcrfill_(&ioct, &dtable[1], &dtable[indic + 1]);
ioct += ioct;
indic += indic;
/* L10: */
}
nrest = ( *nbentr - indic ) << 3;
if (nrest > 0) {
AdvApp2Var_SysBase::mcrfill_(&nrest, &dtable[1], &dtable[indic + 1]);
}
}
return 0 ;
} /* maoverf_ */
//=======================================================================
//function : AdvApp2Var_SysBase::maovsr8_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::maovsr8_(integer *ivalcs)
{
*ivalcs = maovpar_.r8ncs;
return 0 ;
} /* maovsr8_ */
//=======================================================================
//function : matrlog_
//purpose :
//=======================================================================
int matrlog_(const char *,//cnmlog,
const char *,//chaine,
integer *length,
integer *iercod,
ftnlen ,//cnmlog_len,
ftnlen )//chaine_len)
{
*iercod = 1;
*length = 0;
return 0 ;
} /* matrlog_ */
//=======================================================================
//function : matrsym_
//purpose :
//=======================================================================
int matrsym_(const char *cnmsym,
const char *,//chaine,
integer *length,
integer *iercod,
ftnlen cnmsym_len,
ftnlen )//chaine_len)
{
/* Local variables */
char chainx[255] = {};
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* RETURN THE VALUE OF A SYMBOL DEFINED DURING THE */
/* INITIALISATION OF A USER */
/* KEYWORDS : */
/* ----------- */
/* TRANSLATION, SYMBOL */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* CNMSYM : NAME OF THE SYMBOL */
/* OUTPUT ARGUMENTS : */
/* ------------------ */
/* CHAINE : TRANSLATION OF THE SYMBOL */
/* LENGTH : USEFUL LENGTH OF THE CHAIN */
/* IERCOD : ERROR CODE */
/* = 0 : OK */
/* = 1 : INEXISTING SYMBOL */
/* = 2 : OTHER ERROR */
/* COMMONS USED : */
/* ------------------ */
/* NONE */
/* REFERENCES CALLED : */
/* --------------------- */
/* LIB$GET_SYMBOL,MACHDIM */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* - THIS ROUTINE IS VAX SPECIFIC */
/* - IN CASE OF ERROR (IERCOD>0), CHAIN = ' ' AND LENGTH = 0 */
/* - IF THE INPUT VARIABLE CNMSYM IS EMPTY, THE ROUTINE RETURNS IERCOD=1*/
/* > */
/* ***********************************************************************
*/
/* SGI...v */
/* SGI CALL MAGTLOG (CNMSYM,CHAINE,LENGTH,IERCOD) */
magtlog_(cnmsym, chainx, length, iercod, cnmsym_len, 255L);
/* SO...v */
if (*iercod == 5) {
*iercod = 1;
}
/* SO...^ */
if (*iercod >= 2) {
*iercod = 2;
}
//if (__s__cmp(chainx, "NONE", 255L, 4L) == 0) {
if (__s__cmp() == 0) {
//__s__copy(chainx, " ", 255L, 1L);
*length = 0;
}
//__s__copy(chaine, chainx, chaine_len, 255L);
/* SGI...^ */
/* ***********************************************************************
*/
/* ERROR PROCESSING */
/* ***********************************************************************
*/
/* L9999: */
return 0;
} /* matrsym_ */
//=======================================================================
//function : mcrcomm_
//purpose :
//=======================================================================
int mcrcomm_(integer *kop,
integer *noct,
intptr_t *iadr,
integer *ier)
{
/* Initialized data */
integer ntab = 0;
/* System generated locals */
integer i__1, i__2;
/* Local variables */
intptr_t ideb;
doublereal dtab[32000];
intptr_t itab[160] /* was [4][40] */;
intptr_t ipre;
integer i__, j, k;
/************************************************************************
*******/
/* FUNCTION : */
/* ---------- */
/* DYNAMIC ALLOCATION ON COMMON */
/* KEYWORDS : */
/* ----------- */
/* . ALLOCDYNAMIQUE, MEMORY, COMMON, ALLOC */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */
/* NOCT : NUMBER OF OCTETS */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* IADR : ADDRESS IN MEMORY OF THE FIRST OCTET */
/* * : */
/* * : */
/* IERCOD : ERROR CODE */
/* IERCOD = 0 : OK */
/* IERCOD > 0 : CRITICAL ERROR */
/* IERCOD < 0 : WARNING */
/* IERCOD = 1 : ERROR DESCRIPTION */
/* IERCOD = 2 : ERROR DESCRIPTION */
/* COMMONS USED : */
/* ---------------- */
/* CRGEN2 */
/* REFERENCES CALLED : */
/* ---------------------- */
/* Type Name */
/* MCRLOCV */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* ATTENTION .... ITAB ARE NTAB NOT SAVED BETWEEN 2 CALLS..
*/
/* > */
/* ***********************************************************************
*/
/* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */
/* ITAB : TABLE OF MANAGEMENT OF DTAB, ALLOCATED MEMORY ZONE . */
/* NTAB : NUMBER OF COMPLETED ALLOCATIONS. */
/* FORMAT OF ITAB : NUMBER OF ALLOCATED REAL*8, ADDRESS OF THE 1ST REAL*8
*/
/* , NOCT , VIRTUAL ADDRESS */
/* PP COMMON / CRGEN2 / DTAB */
/* ----------------------------------------------------------------------*
*/
*ier = 0;
/* ALLOCATION : FIND A HOLE */
if (*kop == 1) {
*iadr = 0;
if (*noct < 1) {
*ier = 1;
goto L9900;
}
if (ntab >= 40) {
*ier = 2;
goto L9900;
}
i__1 = ntab + 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ <= 1) {
ipre = 1;
} else {
ipre = itab[((i__ - 1) << 2) - 3] + itab[((i__ - 1) << 2) - 4];
}
if (i__ <= ntab) {
ideb = itab[(i__ << 2) - 3];
} else {
ideb = 32001;
}
if ((ideb - ipre) << 3 >= *noct) {
/* A HOLE WAS FOUND */
i__2 = i__;
for (j = ntab; j >= i__2; --j) {
for (k = 1; k <= 4; ++k) {
itab[k + ((j + 1) << 2) - 5] = itab[k + (j << 2) - 5];
/* L1003: */
}
/* L1002: */
}
++ntab;
itab[(i__ << 2) - 4] = *noct / 8 + 1;
itab[(i__ << 2) - 3] = ipre;
itab[(i__ << 2) - 2] = *noct;
mcrlocv_(&dtab[ipre - 1], iadr);
itab[(i__ << 2) - 1] = *iadr;
goto L9900;
}
/* L1001: */
}
/* NO HOLE */
*ier = 3;
goto L9900;
/* ----------------------------------- */
/* DESTRUCTION OF THE ALLOCATION NUM : */
} else {
i__1 = ntab;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*noct != itab[(i__ << 2) - 2]) {
goto L2001;
}
if (*iadr != itab[(i__ << 2) - 1]) {
goto L2001;
}
/* THE ALLOCATION TO BE REMOVED WAS FOUND */
i__2 = ntab;
for (j = i__ + 1; j <= i__2; ++j) {
for (k = 1; k <= 4; ++k) {
itab[k + ((j - 1) << 2) - 5] = itab[k + (j << 2) - 5];
/* L2003: */
}
/* L2002: */
}
--ntab;
goto L9900;
L2001:
;
}
/* THE ALLOCATION DOES NOT EXIST */
*ier = 4;
/* PP GOTO 9900 */
}
L9900:
return 0;
} /* mcrcomm_ */
//=======================================================================
//function : AdvApp2Var_SysBase::mcrdelt_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mcrdelt_(integer *iunit,
integer *isize,
void *t,
intptr_t *iofset,
integer *iercod)
{
integer ibid;
doublereal xbid;
integer noct, iver, ksys, i__, n, nrang,
ibyte, ier;
intptr_t iadfd, iadff, iaddr, loc; /* Les adrresses en long*/
integer kop;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* DESTRUCTION OF A DYNAMIC ALLOCATION */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* IUNIT : NUMBER OF OCTETS OF THE ALLOCATION UNIT */
/* ISIZE : NUMBER OF UNITS REQUIRED */
/* T : REFERENCE ADDRESS */
/* IOFSET : OFFSET */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* IERCOD : ERROR CODE */
/* = 0 : OK */
/* = 1 : PB OF DE-ALLOCATION OF A ZONE ALLOCATED IN COMMON */
/* = 2 : THE SYSTEM REFUSES TO DEMAND DE-ALLOCATION */
/* = 3 : THE ALLOCATION TO BE DESTROYED DOES NOT EXIST. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* 1) UTILISATEUR */
/* ----------- */
/* MCRDELT FREES ALLOCATED MEMORY ZONE */
/* BY ROUTINE MCRRQST (OR CRINCR) */
/* THE MEANING OF ARGUMENTS IS THE SAME AS MCRRQST */
/* *** ATTENTION : */
/* ----------- */
/* IERCOD=2 : CASE WHEN THE SYSTEM CANNOT FREE THE ALLOCATED MEMORY, */
/* THE FOLLOWING MESSAGE APPEARS SYSTEMATICALLY ON CONSOLE ALPHA : */
/* "THe system refuseS destruction of memory allocation" */
/* IERCOD=3 CORRESPONDS TO THE CASE WHEN THE ARGUMENTS ARE NOT CORRECT */
/* (THEY DO NOT ALLOW TO RECOGNIZE THE ALLOCATION IN THE TABLE)
*/
/* When the allocation is destroyed, the corresponding IOFSET is set to */
/* 2 147 483 647. So, if one gets access to the table via IOFSET, there is */
/* a trap. This allows to check that the freed memory zone is not usede. This verification is */
/* valid only if the same sub-program uses and destroys the allocation. */
/* > */
/* ***********************************************************************
*/
/* COMMON OF PARAMETERS */
/* COMMON OF STATISTICS */
/* INCLUDE MCRGENE */
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* TABLE OF MANAGEMENT OF DYNAMIC ALLOCATIONS IN MEMORY */
/* KEYWORS : */
/* ----------- */
/* SYSTEM, MEMORY, ALLOCATION */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
/* 2 : UNIT OF ALLOCATION */
/* 3 : NB OF ALLOCATED UNITS */
/* 4 : REFERENCE ADDRESS OF THE TABLE */
/* 5 : IOFSET */
/* 6 : STATIC ALLOCATION NUMBER */
/* 7 : Required allocation size */
/* 8 : address of the beginning of allocation */
/* 9 : Size of the USER ZONE */
/* 10 : ADDRESS of the START FLAG */
/* 11 : ADDRESS of the END FLAG */
/* 12 : Rank of creation of the allocation */
/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
/* NCORE : NB OF CURRENT ALLOCS */
/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
/* ----------------------------------------------------------------------*
*/
/* 20-10-86 : BF ; INITIAL VERSION */
/* NRQST : NUMBER OF ALLOCATIONS */
/* NDELT : NUMBER OF LIBERATIONS */
/* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
/* MBYTE : MAX NUMBER OF OCTETS */
/* Function Body */
*iercod = 0;
/* SEARCH IN MCRGENE */
n = -1;
mcrlocv_(t, &loc);
for (i__ = mcrgene_.ncore - 1; i__ >= 0; --i__) {
if (*iunit == mcrgene_.icore[i__].unit && *isize ==
mcrgene_.icore[i__].reqsize && loc == mcrgene_.icore[i__].loc
&& *iofset == mcrgene_.icore[i__].offset) {
n = i__;
goto L1100;
}
/* L1001: */
}
L1100:
/* IF THE ALLOCATION DOES NOT EXIST, LEAVE */
if (n < 0) {
goto L9003;
}
/* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */
ksys = mcrgene_.icore[n].alloctype;
ibyte = mcrgene_.icore[n].size;
iaddr = mcrgene_.icore[n].addr;
iadfd = mcrgene_.icore[n].startaddr;
iadff = mcrgene_.icore[n].endaddr;
nrang = mcrgene_.icore[n].rank;
/* Control of flags */
madbtbk_(&iver);
if (iver == 1) {
macrchk_();
}
if (ksys == static_allocation) {
/* DE-ALLOCATION ON COMMON */
kop = 2;
mcrcomm_(&kop, &ibyte, &iaddr, &ier);
if (ier != 0) {
goto L9001;
}
} else {
/* DE-ALLOCATION SYSTEM */
mcrfree_(&ibyte, iaddr, &ier);
if (ier != 0) {
goto L9002;
}
}
/* CALL ALLOWING TO CANCEL AUTOMATIC WATCH BY THE DEBUGGER */
macrclw_(&iadfd, &iadff, &nrang);
/* UPDATE OF STATISTICS */
++mcrstac_.ndelt[ksys];
mcrstac_.nbyte[ksys] -= mcrgene_.icore[n].unit *
mcrgene_.icore[n].reqsize;
/* REMOVAL OF PARAMETERS IN MCRGENE */
if (n < MAX_ALLOC_NB - 1) {
noct = (mcrgene_.ncore - (n + 1)) * sizeof(mcrgene_.icore[0]);
AdvApp2Var_SysBase::mcrfill_(&noct,
&mcrgene_.icore[n + 1],
&mcrgene_.icore[n]);
}
--mcrgene_.ncore;
/* *** Set to overflow of IOFSET */
{
/* nested scope needed to avoid gcc compilation error crossing
initialization with goto*/
/* assign max positive integer to *iofset */
const size_t shift = sizeof (*iofset) * 8 - 1;
*iofset = (uintptr_t(1) << shift) - 1 /*2147483647 for 32bit*/;
}
goto L9900;
/* ----------------------------------------------------------------------*
*/
/* ERROR PROCESSING */
L9001:
/* REFUSE DE-ALLOCATION BY ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
*iercod = 1;
AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
maostrd_();
goto L9900;
/* REFUSE DE-ALLOCATION BY THE SYSTEM */
L9002:
*iercod = 2;
AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
maostrd_();
goto L9900;
/* ALLOCATION DOES NOT EXIST */
L9003:
*iercod = 3;
AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
maostrd_();
goto L9900;
L9900:
return 0 ;
} /* mcrdelt_ */
/*
C*********************************************************************
C
C FUNCTION :
C ----------
C Transfer a memory zone in another by managing intersections
C
C KEYWORDS :
C -----------
C MANIPULATION, MEMORY, TRANSFER, CHARACTER
C
C INPUT ARGUMENTS :
C -----------------
C nb_car : integer*4 number of characters to transfer.
C source : source memory zone.
C
C OUTPUT ARGUMENTS :
C -------------------
C dest : zone memory destination.
C
C COMMONS USED :
C ----------------
C
C REFERENCES CALLED :
C -------------------
C
C DEMSCRIPTION/NOTES/LIMITATIONS :
C -----------------------------------
C Routine portable UNIX (SGI, ULTRIX, BULL)
C
C>
C**********************************************************************
*/
//=======================================================================
//function : AdvApp2Var_SysBase::mcrfill_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mcrfill_(integer *size,
void *tin,
void *tout)
{
char *jmin=static_cast<char*> (tin);
char *jmout=static_cast<char*> (tout);
if (mcrfill_ABS(jmout-jmin) >= *size)
memcpy( tout, tin, *size);
else if (tin > tout)
{
integer n = *size;
while (n-- > 0) *jmout++ = *jmin++;
}
else
{
integer n = *size;
jmin+=n;
jmout+=n;
while (n-- > 0) *--jmout = *--jmin;
}
return 0;
}
/*........................................................................*/
/* */
/* FUNCTION : */
/* ---------- */
/* Routines for management of the dynamic memory. */
/* */
/* Routine mcrfree */
/* -------------- */
/* */
/* Desallocation of a memory zone . */
/* */
/* CALL MCRFREE (IBYTE,IADR,IER) */
/* */
/* IBYTE INTEGER*4 : Nb of Octets to free */
/* */
/* IADR POINTEUR : Start Address */
/* */
/* IER INTEGER*4 : Return Code */
/* */
/* */
/*........................................................................*/
/* */
//=======================================================================
//function : mcrfree_
//purpose :
//=======================================================================
int mcrfree_(integer *,//ibyte,
intptr_t iadr,
integer *ier)
{
*ier=0;
Standard::Free((void*)iadr);
return 0;
}
/*........................................................................*/
/* */
/* FONCTION : */
/* ---------- */
/* Routines for management of the dynamic memory. */
/* */
/* Routine mcrgetv */
/* -------------- */
/* */
/* Demand of memory allocation. */
/* */
/* CALL MCRGETV(IBYTE,IADR,IER) */
/* */
/* IBYTE (INTEGER*4) Nb of Bytes of allocation required */
/* */
/* IADR (INTEGER*4) : Result. */
/* */
/* IER (INTEGER*4) : Error Code : */
/* */
/* = 0 ==> OK */
/* = 1 ==> Allocation impossible */
/* = -1 ==> Ofset > 2**31 - 1 */
/* */
/* */
/*........................................................................*/
//=======================================================================
//function : mcrgetv_
//purpose :
//=======================================================================
int mcrgetv_(integer *sz,
intptr_t *iad,
integer *ier)
{
*ier = 0;
*iad = (intptr_t)Standard::Allocate(*sz);
if ( !*iad ) *ier = 1;
return 0;
}
//=======================================================================
//function : mcrlist_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mcrlist_(integer *ier) const
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Local variables */
char cfmt[1];
doublereal dfmt;
integer ifmt, i__, nufmt, ntotal;
char subrou[7];
/************************************************************************
*******/
/* FUNCTION : */
/* ---------- */
/* PRINT TABLE OF CURRENT DYNAMIC ALLOCATIONS */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, LIST */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* . NONE */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* * : */
/* * : */
/* IERCOD : ERROR CODE */
/* IERCOD = 0 : OK */
/* IERCOD > 0 : SERIOUS ERROR */
/* IERCOD < 0 : WARNING */
/* IERCOD = 1 : ERROR DESCRIPTION */
/* IERCOD = 2 : ERROR DESCRIPTION */
/* COMMONS USED : */
/* ---------------- */
/* MCRGENE VFORMT */
/* REFERENCES CALLED : */
/* ---------------------- */
/* Type Name */
/* VFORMA */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* . NONE */
/* > */
/* ***********************************************************************
*/
/* INCLUDE MCRGENE */
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, MEMORY, ALLOCATION */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
/* 2 : UNIT OF ALLOCATION */
/* 3 : NB OF ALLOCATED UNITS */
/* 4 : REFERENCE ADDRESS OF THE TABLE */
/* 5 : IOFSET */
/* 6 : STATIC ALLOCATION NUMBER */
/* 7 : Required allocation size */
/* 8 : address of the beginning of allocation */
/* 9 : Size of the USER ZONE */
/* 10 : ADDRESS of the START FLAG */
/* 11 : ADDRESS of the END FLAG */
/* 12 : Rank of creation of the allocation */
/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
/* NCORE : NB OF CURRENT ALLOCS */
/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
/* ----------------------------------------------------------------------*
*/
/* ----------------------------------------------------------------------*
*/
*ier = 0;
//__s__copy(subrou, "MCRLIST", 7L, 7L);
/* WRITE HEADING */
nufmt = 1;
ifmt = mcrgene_.ncore;
macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
ntotal = 0;
i__1 = mcrgene_.ncore;
for (i__ = 0; i__ < i__1; ++i__) {
nufmt = 2;
ifmt = mcrgene_.icore[i__].unit * mcrgene_.icore[i__].reqsize
;
macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
ntotal += ifmt;
/* L1001: */
}
nufmt = 3;
ifmt = ntotal;
macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
return 0 ;
} /* mcrlist_ */
//=======================================================================
//function : mcrlocv_
//purpose :
//=======================================================================
int mcrlocv_(void* t,
intptr_t *l)
{
*l = reinterpret_cast<intptr_t> (t);
return 0 ;
}
//=======================================================================
//function : AdvApp2Var_SysBase::mcrrqst_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
integer *isize,
void *t,
intptr_t *iofset,
integer *iercod)
{
integer i__1, i__2;
/* Local variables */
doublereal dfmt;
integer ifmt, iver;
char subr[7];
integer ksys , ibyte, irest, ier;
intptr_t iadfd, iadff, iaddr,lofset, loc;
integer izu;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* IMPLEMENTATION OF DYNAMIC MEMORY ALLOCATION */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, ALLOCATION, MEMORY, REALISATION */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* IUNIT : NUMBER OF OCTET OF THE UNIT OF ALLOCATION */
/* ISIZE : NUMBER OF UNITS REQUIRED */
/* T : REFERENCE ADDRESS */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* IOFSET : OFFSET */
/* IERCOD : ERROR CODE, */
/* = 0 : OK */
/* = 1 : MAX NB OF ALLOCS REACHED */
/* = 2 : ARGUMENTS INCORRECT */
/* = 3 : REFUSED DYNAMIC ALLOCATION */
/* COMMONS USED : */
/* ---------------- */
/* MCRGENE, MCRSTAC */
/* REFERENCES CALLED : */
/* ----------------------- */
/* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* 1) USER */
/* -------------- */
/* T IS THE ADDRESS OF A TABLE, IOFSET REPRESENTS THE DEPLACEMENT IN */
/* UNITS OF IUNIT OCTETS BETWEEN THE ALLOCATED ZONE AND TABLE T */
/* IERCOD=0 SIGNALS THAT THE ALLOCATION WORKS WELL, ANY OTHER */
/* VALUE INDICATES A BUG. */
/* EXAMPLE : */
/* LET THE DECLARATION REAL*4 T(1), SO IUNIT=4 . */
/* CALL TO MCRRQST PORODUCES DYNAMIC ALLOCATION */
/* AND GIVES VALUE TO VARIABLE IOFSET, */
/* IF IT IS REQUIRED TO WRITE 1. IN THE 5TH ZONE REAL*4 */
/* ALLOCATED IN THIS WAY, MAKE: */
/* T(5+IOFSET)=1. */
/* CASE OF ERRORS : */
/* --------------- */
/* IERCOD=1 : MAX NB OF ALLOCATION REACHED (ACTUALLY 200) */
/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
/* "The max number of memory allocation is reached : ,N" */
/* IERCOD=2 : ARGUMENT IUNIT INCORRECT AS IT IS DIFFERENT FROM 1,2,4 OR 8 */
/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
/* "Unit OF allocation invalid : ,IUNIT" */
/* IERCOD=3 : REFUSED DYNAMIC ALLOCATION (MORE PLACE IN MEMORY) */
/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
/* "The system refuses dynamic allocation of memory of N octets"
*/
/* with completev display of all allocations carried out till now */
/* 2) DESIGNER */
/* -------------- */
/* MCRRQST MAKES DYNAMIC ALLOCATION OF VIRTUAL MEMORY ON THE BASE */
/* OF ENTITIES OF 8 OCTETS (QUADWORDS), WHILE THE ALLOCATION IS REQUIRED BY */
/* UNITS OF IUNIT OCTETS (1,2,4,8). */
/* THE REQUIRED QUANTITY IS IUNIT*ISIZE OCTETS, THIS VALUE IS ROUNDED */
/* SO THAT THE ALLOCATION WAS AN INTEGER NUMBER OF QUADWORDS. */
/* > */
/* ***********************************************************************
*/
/* COMMON OF PARAMETRES */
/* COMMON OF INFORMATION ON STATISTICS */
/* INCLUDE MCRGENE */
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
/* KEYWORDS : */
/* ----------- */
/* SYSTEM, MEMORY, ALLOCATION */
/* DEMSCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
/* 2 : UNIT OF ALLOCATION */
/* 3 : NB OF ALLOCATED UNITS */
/* 4 : REFERENCE ADDRESS OF THE TABLE */
/* 5 : IOFSET */
/* 6 : STATIC ALLOCATION NUMBER */
/* 7 : Required allocation size */
/* 8 : address of the beginning of allocation */
/* 9 : Size of the USER ZONE */
/* 10 : ADDRESS of the START FLAG */
/* 11 : ADDRESS of the END FLAG */
/* 12 : Rank of creation of the allocation */
/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
/* NCORE : NB OF CURRENT ALLOCS */
/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
/* ----------------------------------------------------------------------*
*/
/* 20-10-86 : BF ; INITIAL VERSION */
/* NRQST : NUMBER OF ALLOCATIONS */
/* NDELT : NUMBER OF LIBERATIONS */
/* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
/* MBYTE : MAX NUMBER OF OCTETS */
/* ----------------------------------------------------------------------*
*/
/* Function Body */
*iercod = 0;
if (mcrgene_.ncore >= MAX_ALLOC_NB) {
goto L9001;
}
if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
goto L9002;
}
/* Calculate the size required by the user */
ibyte = *iunit * *isize;
/* Find the type of version (Phase of Production or Version Client) */
madbtbk_(&iver);
/* Control allocated size in Production phase */
if (iver == 1) {
if (ibyte == 0) {
//do__lio(&c__9, &c__1, "Require zero allocation", 26L);
maostrb_();
} else if (ibyte >= 4096000) {
//do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L);
//do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
maostrb_();
}
}
/* CALCULATE THE SIZE OF THE USER ZONE (IZU) */
/* . add size required by the user (IBYTE) */
/* . add delta for alinement with the base */
/* . round to multiple of 8 above */
mcrlocv_(t, &loc);
izu = ibyte + loc % *iunit;
irest = izu % 8;
if (irest != 0) {
izu = izu + 8 - irest;
}
/* CALCULATE THE SIZE REQUIRED FROM THE PRIMITIVE OF ALLOC */
/* . add size of the user zone */
/* . add 8 for alinement of start address of */
/* allocation on multiple of 8 so that to be able to */
/* set flags with Double Precision without other pb than alignement */
/* . add 16 octets for two flags */
ibyte = izu + 24;
/* DEMAND OF ALLOCATION */
/* L1001: */
/* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
/* ALLOCATION SUR TABLE */
/* KSYS = 1 */
/* KOP = 1 */
/* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
/* IF ( IER .NE. 0 ) THEN */
/* ISYST=1 */
/* GOTO 1001 */
/* ENDIF */
/* ELSE */
/* ALLOCATION SYSTEME */
ksys = heap_allocation;
mcrgetv_(&ibyte, &iaddr, &ier);
if (ier != 0) {
goto L9003;
}
/* ENDIF */
/* CALCULATE THE ADDRESSES OF FLAGS */
iadfd = iaddr + 8 - iaddr % 8;
iadff = iadfd + 8 + izu;
/* CALCULATE USER OFFSET : */
/* . difference between the user start address and the */
/* base address */
/* . converts this difference in the user unit */
lofset = iadfd + 8 + loc % *iunit - loc;
*iofset = lofset / *iunit;
/* If phase of production control flags */
if (iver == 1) {
macrchk_();
}
/* SET FLAGS */
/* . the first flag is set by IADFD and the second by IADFF */
/* . if phase of production, set to overflow the ZU */
macrgfl_(&iadfd, &iadff, &iver, &izu);
/* RANGING OF PARAMETERS IN MCRGENE */
mcrgene_.icore[mcrgene_.ncore].prot = mcrgene_.lprot;
mcrgene_.icore[mcrgene_.ncore].unit = (unsigned char)(*iunit);
mcrgene_.icore[mcrgene_.ncore].reqsize = *isize;
mcrgene_.icore[mcrgene_.ncore].loc = loc;
mcrgene_.icore[mcrgene_.ncore].offset = *iofset;
mcrgene_.icore[mcrgene_.ncore].alloctype = (unsigned char)ksys;
mcrgene_.icore[mcrgene_.ncore].size = ibyte;
mcrgene_.icore[mcrgene_.ncore].addr = iaddr;
mcrgene_.icore[mcrgene_.ncore].userzone = mcrgene_.ncore;
mcrgene_.icore[mcrgene_.ncore].startaddr = iadfd;
mcrgene_.icore[mcrgene_.ncore].endaddr = iadff;
mcrgene_.icore[mcrgene_.ncore].rank = mcrgene_.ncore + 1;
++mcrgene_.ncore;
mcrgene_.lprot = 0;
/* CALL ALLOWING AUTOIMPLEMENTATION OF THE SET WATCH BY THE DEBUGGER */
macrstw_(&iadfd, &iadff, &mcrgene_.ncore);
/* STATISTICS */
++mcrstac_.nrqst[ksys];
mcrstac_.nbyte[ksys] += mcrgene_.icore[mcrgene_.ncore - 1].unit *
mcrgene_.icore[mcrgene_.ncore - 1].reqsize;
/* Computing MAX */
i__1 = mcrstac_.mbyte[ksys], i__2 = mcrstac_.nbyte[ksys];
mcrstac_.mbyte[ksys] = advapp_max(i__1,i__2);
goto L9900;
/* ----------------------------------------------------------------------*
*/
/* ERROR PROCESSING */
/* MAX NB OF ALLOC REACHED : */
L9001:
*iercod = 1;
ifmt = MAX_ALLOC_NB;
//__s__copy(subr, "MCRRQST", 7L, 7L);
macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
maostrd_();
goto L9900;
/* INCORRECT ARGUMENTS */
L9002:
*iercod = 2;
ifmt = *iunit;
//__s__copy(subr, "MCRRQST", 7L, 7L);
macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
goto L9900;
/* SYSTEM REFUSES ALLOCATION */
L9003:
*iercod = 3;
ifmt = ibyte;
//__s__copy(subr, "MCRRQST", 7L, 7L);
macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
maostrd_();
mcrlist_(&ier);
goto L9900;
/* ----------------------------------------------------------------------*
*/
L9900:
mcrgene_.lprot = 0;
return 0 ;
} /* mcrrqst_ */
//=======================================================================
//function : AdvApp2Var_SysBase::mgenmsg_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
ftnlen )//nomprg_len)
{
return 0;
} /* mgenmsg_ */
//=======================================================================
//function : AdvApp2Var_SysBase::mgsomsg_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
ftnlen )//nomprg_len)
{
return 0;
} /* mgsomsg_ */
/*
C
C*****************************************************************************
C
C FUNCTION : CALL MIRAZ(LENGTH,ITAB)
C ----------
C
C RESET TO ZERO A TABLE OF LOGIC OR INTEGER.
C
C KEYWORDS :
C -----------
C RAZ INTEGER
C
C INPUT ARGUMENTS :
C ------------------
C LENGTH : NUMBER OF OCTETS TO TRANSFER
C ITAB : NAME OF THE TABLE
C
C OUTPUT ARGUMENTS :
C -------------------
C ITAB : NAME OF THE TABLE SET TO ZERO
C
C COMMONS USED :
C ----------------
C
C REFERENCES CALLED :
C ---------------------
C
C DEMSCRIPTION/NOTES/LIMITATIONS :
C -----------------------------------
C
C Portable VAX-SGI
C>
C***********************************************************************
*/
//=======================================================================
//function : AdvApp2Var_SysBase::miraz_
//purpose :
//=======================================================================
void AdvApp2Var_SysBase::miraz_(integer *taille,
void *adt)
{
memset(adt , '\0' , *taille) ;
}
//=======================================================================
//function : AdvApp2Var_SysBase::mnfndeb_
//purpose :
//=======================================================================
integer AdvApp2Var_SysBase::mnfndeb_()
{
integer ret_val;
ret_val = 0;
return ret_val;
} /* mnfndeb_ */
//=======================================================================
//function : AdvApp2Var_SysBase::msifill_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::msifill_(integer *nbintg,
integer *ivecin,
integer *ivecou)
{
integer nocte;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* transfer Integer from one zone to another */
/* KEYWORDS : */
/* ----------- */
/* TRANSFER , INTEGER , MEMORY */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NBINTG : Nb of integers */
/* IVECIN : Input vector */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* IVECOU : Output vector */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ___ NOCTE : Number of octets to transfer */
/* Parameter adjustments */
--ivecou;
--ivecin;
/* Function Body */
nocte = *nbintg * sizeof(integer);
AdvApp2Var_SysBase::mcrfill_(&nocte, &ivecin[1], &ivecou[1]);
return 0 ;
} /* msifill_ */
//=======================================================================
//function : AdvApp2Var_SysBase::msrfill_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
doublereal *vecent,
doublereal * vecsor)
{
integer nocte;
/* ***********************************************************************
*/
/* FONCTION : */
/* ---------- */
/* Transfer real from one zone to another */
/* KEYWORDS : */
/* ----------- */
/* TRANSFER , REAL , MEMORY */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* NBREEL : Number of reals */
/* VECENT : Input vector */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* VECSOR : Output vector */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* ___ NOCTE : Nb of octets to transfer */
/* Parameter adjustments */
--vecsor;
--vecent;
/* Function Body */
nocte = *nbreel * sizeof (doublereal);
AdvApp2Var_SysBase::mcrfill_(&nocte, &vecent[1], &vecsor[1]);
return 0 ;
} /* msrfill_ */
//=======================================================================
//function : AdvApp2Var_SysBase::mswrdbg_
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
ftnlen )//ctexte_len)
{
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Write message on console alpha if IBB>0 */
/* KEYWORDS : */
/* ----------- */
/* MESSAGE, DEBUG */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* CTEXTE : Text to be written */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* None */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* DECLARATIONS */
/* ***********************************************************************
*/
/* ***********************************************************************
*/
/* PROCESSING */
/* ***********************************************************************
*/
if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
//do__lio(&c__9, &c__1, "Dbg ", 4L);
//do__lio(&c__9, &c__1, ctexte, ctexte_len);
}
return 0 ;
} /* mswrdbg_ */
int __i__len()
{
return 0;
}
int __s__cmp()
{
return 0;
}
//=======================================================================
//function : do__fio
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::do__fio()
{
return 0;
}
//=======================================================================
//function : do__lio
//purpose :
//=======================================================================
int AdvApp2Var_SysBase::do__lio ()
{
return 0;
}
/*
C*****************************************************************************
C
C FUNCTION : CALL MVRIRAZ(NBELT,DTAB)
C ----------
C Reset to zero a table with DOUBLE PRECISION
C
C KEYWORDS :
C -----------
C MVRMIRAZ DOUBLE
C
C INPUT ARGUMENTS :
C ------------------
C NBELT : Number of elements of the table
C DTAB : Table to initializer to zero
C
C OUTPUT ARGUMENTS :
C --------------------
C DTAB : Table reset to zero
C
C COMMONS USED :
C ----------------
C
C REFERENCES CALLED :
C -----------------------
C
C DEMSCRIPTION/NOTES/LIMITATIONS :
C -----------------------------------
C
C
C>
C***********************************************************************
*/
//=======================================================================
//function : AdvApp2Var_SysBase::mvriraz_
//purpose :
//=======================================================================
void AdvApp2Var_SysBase::mvriraz_(integer *taille,
void *adt)
{
integer offset;
offset = *taille * 8 ;
/* printf(" adt %d long %d\n",adt,offset); */
memset(adt , '\0' , offset) ;
}
View Git Blame Copy Permalink