// Copyright (c) 1999-2012 OPEN CASCADE SAS // // The content of this file is subject to the Open CASCADE Technology Public // License Version 6.5 (the "License"). You may not use the content of this file // except in compliance with the License. Please obtain a copy of the License // at http://www.opencascade.org and read it completely before using this file. // // The Initial Developer of the Original Code is Open CASCADE S.A.S., having its // main offices at: 1, place des Freres Montgolfier, 78280 Guyancourt, France. // // The Original Code and all software distributed under the License is // distributed on an "AS IS" basis, without warranty of any kind, and the // Initial Developer hereby disclaims all such warranties, including without // limitation, any warranties of merchantability, fitness for a particular // purpose or non-infringement. Please see the License for the specific terms // and conditions governing the rights and limitations under the License. // AdvApp2Var_SysBase.cxx #include #include #include #include #include #include #include static int __i__len(); static int __s__cmp(); static int macrbrk_(); static int macrchk_(); 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, void* *iadr, integer *ier); static int mcrgetv_(integer *sz, void* *iad, integer *ier); static int mcrlist_(integer *ier); static int mcrlocv_(void* t, intptr_t *l); /* Structures */ static struct { intptr_t icore[12000]; integer ncore, lprot; } mcrgene_; static struct { integer nrqst[2], ndelt[2], nbyte[2], mbyte[2]; } mcrstac_; static struct { integer lec, imp, keyb, mae, jscrn, itblt, ibb; } mblank__; #define mcrfill_ABS(a) (((a)<0)?(-(a)):(a)) //======================================================================= //function : macinit_ //purpose : //======================================================================= int AdvApp2Var_SysBase::macinit_(integer *imode, integer *ival) { /* Fortran I/O blocks */ static cilist io______1 = { 0, 0, 0, (char*) "(' --- Debug-mode : ',I10,' ---')", 0 }; /* ************************************************************************/ /* 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; io______1.ciunit = mblank__.imp; /* s__wsfe(&io______1); */ /* do__fio(&c____1, (char *)&mblank__.ibb, (ftnlen)sizeof(integer)); */ AdvApp2Var_SysBase::e__wsfe(); } 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; /* Parameter adjustments */ --itablo; iunit = sizeof(integer); /* Function Body */ if (*nbelem > *maxelm) { AdvApp2Var_SysBase::mcrrqst_(&iunit, nbelem, &itablo[1], 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) { static 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. */ /* > */ /* *********************************************************************** */ /* Parameter adjustments */ --xtablo; /* Function Body */ if (*nbelem > *maxelm) { AdvApp2Var_SysBase::mcrrqst_(&c__8, nbelem, &xtablo[1], iofset, iercod); } else { *iercod = 0; *iofset = 0; } return 0 ; } /* macrar8_ */ //======================================================================= //function : macrbrk_ //purpose : //======================================================================= int macrbrk_() { return 0 ; } /* macrbrk_ */ //======================================================================= //function : macrchk_ //purpose : //======================================================================= int macrchk_() { /* System generated locals */ integer i__1; /* Local variables */ static integer i__, j; static intptr_t ioff; static doublereal t[1]; static 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__ = 1; i__ <= i__1; ++i__) { for (j = 10; j <= 11; ++j) { if (mcrgene_.icore[j + i__ * 12 - 13] != -1) { ioff = (mcrgene_.icore[j + i__ * 12 - 13] - loc) / 8; if (t[ioff] != -134744073.) { /* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS E:',ICORE(J,I) */ /* AND OF RANK ICORE(12,I) */ macrerr_(&mcrgene_.icore[j + i__ * 12 - 13], &mcrgene_.icore[i__ * 12 - 1]); /* BACK-PARCING IN PHASE OF PRODUCTION */ maostrb_(); /* REMOVAL OF THE ADDRESS OF FLAG TO AVOID REMAKING ITS CONTROL */ mcrgene_.icore[j + i__ * 12 - 13] = -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; /* Parameter adjustments */ --itablo; iunit = sizeof(integer); /* Function Body */ if (*iofset != 0) { AdvApp2Var_SysBase::mcrdelt_(&iunit, nbelem, &itablo[1], 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) { static 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) */ /* > */ /* *********************************************************************** */ /* Parameter adjustments */ --xtablo; /* Function Body */ if (*iofset != 0) { AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, &xtablo[1], iofset, iercod); } else { *iercod = 0; } return 0 ; } /* macrdr8_ */ //======================================================================= //function : macrerr_ //purpose : //======================================================================= int macrerr_(intptr_t *,//iad, intptr_t *)//nalloc) { //static integer c__1 = 1; /* Builtin functions */ //integer /*s__wsfe(),*/ /*do__fio(),*/ e__wsfe(); /* Fortran I/O blocks */ //static 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 : */ /* ----------------------------------- */ /* > */ /* *********************************************************************** */ /* s__wsfe(&io___1); */ /* 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)); */ AdvApp2Var_SysBase::e__wsfe(); return 0 ; } /* macrerr_ */ //======================================================================= //function : macrgfl_ //purpose : //======================================================================= int macrgfl_(intptr_t *iadfld, intptr_t *iadflf, integer *iphase, integer *iznuti) { /* Initialized data */ static integer ifois = 0; static char cbid[1]; static integer ibid, ienr; static doublereal t[1]; static integer novfl; static intptr_t ioff,iadrfl, 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 : */ iadrfl = *iadfld; macrbrk_(); /* UPDATE THE START FLAG */ ioff = (*iadflf - iadt) / 8; t[ioff] = -134744073.; /* FAKE CALL TO STOP THE DEBUGGER : */ iadrfl = *iadflf; 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 */ static integer inum, iunite; static char cfm[80], cln[3]; /* Fortran I/O blocks */ static cilist io___5 = { 0, 0, 0, cfm, 0 }; static cilist io___6 = { 0, 0, 0, cfm, 0 }; static cilist io___7 = { 0, 0, 0, cfm, 0 }; /* *********************************************************************** */ /* 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; --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 : */ iunite = AdvApp2Var_SysBase::mnfnimp_(); if (inum == 0) { io___5.ciunit = iunite; /* s__wsfe(&io___5); */ AdvApp2Var_SysBase::e__wsfe(); } else if (inum == 1) { io___6.ciunit = iunite; /* s__wsfe(&io___6); */ /* do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer)); */ AdvApp2Var_SysBase::e__wsfe(); } else { /* MESSAGE DOES NOT EXIST ... */ io___7.ciunit = iunite; /* s__wsfe(&io___7); */ /* do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer)); do__fio(&c__1, crout, crout_len); */ AdvApp2Var_SysBase::e__wsfe(); } 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 */ static char cbid[255]; static 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; return 0 ; } /* mainial_ */ //======================================================================= //function : AdvApp2Var_SysBase::maitbr8_ //purpose : //======================================================================= int AdvApp2Var_SysBase::maitbr8_(integer *itaill, doublereal *xtab, doublereal *xval) { static integer c__504 = 504; /* Initialized data */ static 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 */ static integer i__; static doublereal buffx[63]; static 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 INFORMATIONS 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_() { static 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 */ static integer ifois = 0; /* System generated locals */ integer i__1; /* Local variables */ static integer ibid; static doublereal buff[63]; static 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 developpement 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 */ /* *********************************************************************** */ /* 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 */ /* DATAS */ /* 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 */ static 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 */ static integer ntab = 0; /* System generated locals */ integer i__1, i__2; /* Local variables */ static intptr_t ideb; static doublereal dtab[32000]; static intptr_t itab[160] /* was [4][40] */; static intptr_t ipre; static 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) { static integer ibid; static doublereal xbid; static integer noct, iver, ksys, i__, n, nrang, ibyte, ier; static intptr_t iadfd, iadff, iaddr, loc; /* Les adrresses en long*/ static 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 = 0; mcrlocv_(t, &loc); for (i__ = mcrgene_.ncore; i__ >= 1; --i__) { if (*iunit == mcrgene_.icore[i__ * 12 - 11] && *isize == mcrgene_.icore[i__ * 12 - 10] && loc == mcrgene_.icore[i__ * 12 - 9] && *iofset == mcrgene_.icore[i__ * 12 - 8]) { n = i__; goto L1100; } /* L1001: */ } L1100: /* IF THE ALLOCATION DOES NOT EXIST, LEAVE */ if (n <= 0) { goto L9003; } /* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */ ksys = static_cast (mcrgene_.icore[n * 12 - 7]); ibyte = static_cast (mcrgene_.icore[n * 12 - 6]); iaddr = mcrgene_.icore[n * 12 - 5]; iadfd = mcrgene_.icore[n * 12 - 3]; iadff = mcrgene_.icore[n * 12 - 2]; nrang = static_cast (mcrgene_.icore[n * 12 - 1]); /* Control of flags */ madbtbk_(&iver); if (iver == 1) { macrchk_(); } if (ksys <= 1) { /* DE-ALLOCATION ON COMMON */ kop = 2; mcrcomm_(&kop, &ibyte, &iaddr, &ier); if (ier != 0) { goto L9001; } } else { /* DE-ALLOCATION SYSTEM */ mcrfree_(&ibyte, reinterpret_cast (&iaddr), &ier); if (ier != 0) { goto L9002; } } /* CALL ALLOWING TO CANCEL AUTOMATIC WATCH BY THE DEBUGGER */ macrclw_(&iadfd, &iadff, &nrang); /* UPDATE OF STATISTICS */ if (ksys <= 1) { i__ = 1; } else { i__ = 2; } ++mcrstac_.ndelt[i__ - 1]; mcrstac_.nbyte[i__ - 1] -= static_cast (mcrgene_.icore[n * 12 - 11] * mcrgene_.icore[n * 12 - 10]); /* REMOVAL OF PARAMETERS IN MCRGENE */ if (n < 1000) { /* noct = (mcrgene_1.ncore - n) * 48; */ noct = (mcrgene_.ncore - n) * 12 * sizeof(mcrgene_.icore[0]); AdvApp2Var_SysBase::mcrfill_(&noct, &mcrgene_.icore[(n + 1) * 12 - 12], &mcrgene_.icore[n * 12 - 12]); } --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) { register char *jmin=static_cast (tin); register char *jmout=static_cast (tout); if (mcrfill_ABS(jmout-jmin) >= *size) memcpy( tout, tin, *size); else if (tin > tout) { register integer n = *size; while (n-- > 0) *jmout++ = *jmin++; } else { register 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, void* *iadr, integer *ier) { *ier=0; Standard::Free(*iadr); //Standard::Free always nullifies address, so check becomes incorrect //if ( !*iadr ) *ier = 1; 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, void* *iad, integer *ier) { *ier = 0; *iad = Standard::Allocate(*sz); if ( !*iad ) *ier = 1; return 0; } //======================================================================= //function : mcrlist_ //purpose : //======================================================================= int mcrlist_(integer *ier) { /* System generated locals */ integer i__1; /* Builtin functions */ /* Local variables */ static char cfmt[1]; static doublereal dfmt; static integer ifmt, i__, nufmt, ntotal; static 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__ = 1; i__ <= i__1; ++i__) { nufmt = 2; ifmt = static_cast (mcrgene_.icore[i__ * 12 - 11] * mcrgene_.icore[i__ * 12 - 10]) ; 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 (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 */ static doublereal dfmt; static integer ifmt, iver; static char subr[7]; static integer ksys , ibyte, irest, isyst, ier; static intptr_t iadfd, iadff, iaddr,lofset, loc; static 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 >= 1000) { 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) { //s__wsle(&io___3); //do__lio(&c__9, &c__1, "Require zero allocation", 26L); AdvApp2Var_SysBase::e__wsle(); maostrb_(); } else if (ibyte >= 4096000) { //s__wsle(&io___4); //do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L); //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer)); AdvApp2Var_SysBase::e__wsle(); 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 */ isyst = 0; /* 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 = 2; mcrgetv_(&ibyte, reinterpret_cast (&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_.ncore; mcrgene_.icore[mcrgene_.ncore * 12 - 12] = mcrgene_.lprot; mcrgene_.icore[mcrgene_.ncore * 12 - 11] = *iunit; mcrgene_.icore[mcrgene_.ncore * 12 - 10] = *isize; mcrgene_.icore[mcrgene_.ncore * 12 - 9] = loc; mcrgene_.icore[mcrgene_.ncore * 12 - 8] = *iofset; mcrgene_.icore[mcrgene_.ncore * 12 - 7] = ksys; mcrgene_.icore[mcrgene_.ncore * 12 - 6] = ibyte; mcrgene_.icore[mcrgene_.ncore * 12 - 5] = iaddr; mcrgene_.icore[mcrgene_.ncore * 12 - 4] = mcrgene_.ncore; mcrgene_.icore[mcrgene_.ncore * 12 - 3] = iadfd; mcrgene_.icore[mcrgene_.ncore * 12 - 2] = iadff; mcrgene_.icore[mcrgene_.ncore * 12 - 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 - 1]; mcrstac_.nbyte[ksys - 1] += static_cast (mcrgene_.icore[mcrgene_.ncore * 12 - 11] * mcrgene_.icore[mcrgene_.ncore * 12 - 10]); /* Computing MAX */ i__1 = mcrstac_.mbyte[ksys - 1], i__2 = mcrstac_.nbyte[ksys - 1]; mcrstac_.mbyte[ksys - 1] = advapp_max(i__1,i__2); goto L9900; /* ----------------------------------------------------------------------* */ /* ERROR PROCESSING */ /* MAX NB OF ALLOC REACHED : */ L9001: *iercod = 1; ifmt = 1000; //__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) { integer offset; offset = *taille; 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::mnfnimp_ //purpose : //======================================================================= integer AdvApp2Var_SysBase::mnfnimp_() { integer ret_val; ret_val = 6; return ret_val; } /* mnfnimp_ */ //======================================================================= //function : AdvApp2Var_SysBase::msifill_ //purpose : //======================================================================= int AdvApp2Var_SysBase::msifill_(integer *nbintg, integer *ivecin, integer *ivecou) { static 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) { static 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) { static cilist io___1 = { 0, 0, 0, 0, 0 }; /* *********************************************************************** */ /* 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) { io___1.ciunit = AdvApp2Var_SysBase::mnfnimp_(); //s__wsle(&io___1); //do__lio(&c__9, &c__1, "Dbg ", 4L); //do__lio(&c__9, &c__1, ctexte, ctexte_len); AdvApp2Var_SysBase::e__wsle(); } 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; } //======================================================================= //function : e__wsfe //purpose : //======================================================================= int AdvApp2Var_SysBase::e__wsfe () { return 0; } //======================================================================= //function : e__wsle //purpose : //======================================================================= int AdvApp2Var_SysBase::e__wsle () { return 0; } //======================================================================= //function : s__wsfe //purpose : //======================================================================= int AdvApp2Var_SysBase::s__wsfe () { return 0; } //======================================================================= //function : s__wsle //purpose : //======================================================================= int AdvApp2Var_SysBase::s__wsle () { 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) ; }