// // AdvApp2Var_SysBase.cxx // #include #include #include #include #include // #include static int __i__len(); static int __s__cmp(); static int macrbrk_(); static int macrchk_(); static int macrclw_(long int *iadfld, long int *iadflf, integer *nalloc); static int macrerr_(long int *iad, integer *nalloc); static int macrgfl_(long int *iadfld, long int *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_(integer *iadfld, integer *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, long int *iadr, integer *ier); static int mcrfree_(integer *ibyte, uinteger *iadr, integer *ier); static int mcrgetv_(integer *sz, uinteger *iad, integer *ier); static int mcrlist_(integer *ier); static int mcrlocv_(long int t, long int *l); /* Structures */ static struct { long int 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 }; /* ************************************************************************/ /* FONCTION : */ /* ---------- */ /* INITIALISATION DES UNITES DE LECTURE-ECRITURE, ET DE 'IBB' */ /* MOTS CLES : */ /* ----------- */ /* GESTION, CONFIGURATION, UNITES, INITIALISATION */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* IMODE : MODE D'INIT : 0= DEFAUT, IMP VAUDRA 6 ET IBB 0 */ /* ET LEC 5 */ /* 1= FORCE LA VALEUR DE IMP */ /* 2= FORCE LA VALEUR DE IBB */ /* 3= FORCE LA VALEUR DE LEC */ /* ARGUMENT UTILISE QUE LORSQUE IMODE VAUT 1 OU 2 : */ /* IVAL : VALEUR DE IMP LORSQUE IMODE VAUT 1 */ /* VALEUR DE IBB LORSQUE IMODE VAUT 2 */ /* VALEUR DE LEC LORSQUE IMODE VAUT 3 */ /* IL N'Y A PAS DE CONTROLE SUR LA VALIDITE DE LA VALEUR DE IVAL . */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* IL NE S'AGIT QUE D'INITIALISER LE COMMON BLANK POUR TOUS LES */ /* MODULES QUI N'ONT A PRIORI PAS BESOIN DE CONNAITRE LES COMMONS */ /* DE T . */ /* LORSQU'UNE MODIFICATION DE IBB EST DEMANDEE (IMODE=2) UN MESSAGE */ /* D'INFORMATION EST EMIS SUR IMP, AVEC LA NOUVELLE VALEUR DE IBB. */ /* IBB : MODE DEBUG DE STRIM T : REGLES D'UTILISATION : */ /* 0 VERSION SOBRE */ /* >0 LA VERSION A D'AUTANT PLUS DE COMMENTAIRES */ /* QUE IBB EST GRAND . */ /* PAR EXEMPLE AVEC IBB=1 LES ROUTINES APPELEES */ /* SE SIGNALENT SUR IMP ('ENTREE DANS TOTO', */ /* ET 'SORTIE DE TOTO'), ET LES ROUTINES RENVOYANT */ /* UN CODE ERREUR NON NUL LE SIGNALENT EGALEMENT. */ /* (MAIS CECI N'EST PAS VRAI POUR TOUTES LES ROUTINES DE T) */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 22-12-89 : DGZ; MODIFICATION EN-TETE */ /* 30-05-88 : PP ; AJOUT DE LEC */ /* 15-03-88 : PP ; ECRITURE VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ 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, long int *iofset, integer *iercod) { /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Demande d'allocation dynamique de type INTEGER */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, REALISATION */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NBELEM : Nombre d'unites demandes */ /* MAXELM : Nombre maxi d'unites disponibles dans ITABLO */ /* ITABLO : Adresse de reference de la zone allouee */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* IOFSET : Decalage */ /* IERCOD : Code d'erreur */ /* = 0 : OK */ /* = 1 : Nbre maxi d'allocs atteint */ /* = 2 : Arguments incorrects */ /* = 3 : Refus d'allocation dynamique */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MCRRQST */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* (Cf description dans l'entete de MCRRQST) */ /* Le tableau ITABLO doit etre dimensionne a MAXELM par l'appelant. */ /* Si la demande est inferieure ou egale a MAXELM, IOFSET rendu = 0. */ /* Sinon, la demande d'allocation est effective et IOFSET > 0. */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 16-10-91 : DGZ ; Recuperation version FBI */ /* > */ /* *********************************************************************** */ integer iunit; /* Parameter adjustments */ --itablo; iunit = sizeof(integer); /* Function Body */ if (*nbelem > *maxelm) { AdvApp2Var_SysBase::mcrrqst_(&iunit, nbelem, (doublereal *)&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, long int *iofset, integer *iercod) { static integer c__8 = 8; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Demande d'allocation dynamique de type DOUBLE PRECISION */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, REALISATION */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NBELEM : Nombre d'unites demandes */ /* MAXELM : Nombre maxi d'unites disponibles dans XTABLO */ /* XTABLO : Adresse de reference de la zone allouee */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* IOFSET : Decalage */ /* IERCOD : Code d'erreur */ /* = 0 : OK */ /* = 1 : Nbre maxi d'allocs atteint */ /* = 2 : Arguments incorrects */ /* = 3 : Refus d'allocation dynamique */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MCRRQST */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* (Cf description dans l'entete de MCRRQST) */ /* Le tableau XTABLO doit etre dimensionne a MAXELM par l'appelant. */ /* Si la demande est inferieure ou egale a MAXELM, IOFSET rendu = 0. */ /* Sinon, la demande d'allocation est effective et IOFSET > 0. */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 16-10-91 : DGZ ; Recuperation version FBI */ /* > */ /* *********************************************************************** */ /* 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 long int ioff; static doublereal t[1]; static integer loc; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* CONTROLE LES DEBORDEMENTS DE ZONE MEMOIRE ALLOUEES */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, CONTROLE, DEBORDEMENT */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NEANT */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* MCRGENE */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MACRERR, MAOSTRD */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 18-11-91 : DGZ; AC91118Z0000 : Resactivation */ /* 17-10-91 : FCR; AC91118Z0000 : Desactivation */ /* 25-09-91 : DGZ; GESTION DES FLAGS DANS MCRGENE */ /* 31-07-90 : DGZ; AJOUT TRACE-BACK EN PHASE DE PRODUCTION */ /* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS . */ /* 03-10-89 : DGZ; REMPLACE COMMON ACFLAG PAR INCLUDE ACFLAG.INC */ /* 09-06-89 : PP ; CORRECTION DES CALCULS D'OFFSET */ /* 31-05-89 : DGZ; APPEL MCRLOCV EN DEHORS BOUCLE DO */ /* 25-05-89 : DGZ; CHANGE DIM ACRTAB : MALLOC PASSE DE 10000 A 200 */ /* 16-05-89 : PP ; AJOUT DE MACRERR, POUR ARRET SOUS DBG */ /* 11-05-89 : DGZ ; CREATION DE LA VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, MEMOIRE, ALLOCATION */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */ /* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */ /* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */ /* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */ /* + AJOUT DE COMMENTAIRES */ /* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */ /* 15-04-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */ /* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */ /* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */ /* 2 : UNITE D'ALLOCATION */ /* 3 : NB D'UNITES ALLOUEES */ /* 4 : ADRESSE DE REFERENCE DU TABLEAU */ /* 5 : IOFSET */ /* 6 : NUMERO ALLOCATION STATIQUE */ /* 7 : Taille demandee en allocation */ /* 8 : adresse du debut de l'allocation */ /* 9 : Taille de la ZONE UTILISATEUR */ /* 10 : ADRESSE DU FLAG DE DEBUT */ /* 11 : ADRESSE DU FLAG DE FIN */ /* 12 : Rang de creation de l'allocation */ /* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */ /* NCORE : NBRE D'ALLOCS EN COURS */ /* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST */ /* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */ /* ----------------------------------------------------------------------* */ /* ----------------------------------------------------------------------* */ /* CALCUL ADRESSE DE T */ mcrlocv_((long int)t, (long int *)&loc); /* CONTROLE DES FLAGS DANS LE TABLEAU */ 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 : ECRASEMENT DE LA MEMOIRE D''ADRESS E:',ICORE(J,I) */ /* ET DE RANG ICORE(12,I) */ macrerr_((long int *)&mcrgene_.icore[j + i__ * 12 - 13], (integer *)&mcrgene_.icore[i__ * 12 - 1]); /* TRACE-BACK EN PHASE DE PRODUCTION */ maostrb_(); /* SUPPRESSION DE L'ADRESSE DU FLAG POUR NE PLUS REFAIRE S ON CONTROLE */ mcrgene_.icore[j + i__ * 12 - 13] = -1; } } /* L100: */ } /* L1000: */ } return 0 ; } /* macrchk_ */ //======================================================================= //function : macrclw_ //purpose : //======================================================================= int macrclw_(long int *,//iadfld, long int *,//iadflf, integer *)//nalloc) { return 0 ; } /* macrclw_ */ //======================================================================= //function : AdvApp2Var_SysBase::macrdi4_ //purpose : //======================================================================= int AdvApp2Var_SysBase::macrdi4_(integer *nbelem, integer *,//maxelm, integer *itablo, long int *iofset, /* Offset en long (pmn) */ integer *iercod) { /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Destruction d'une allocation dynamique de type INTEGER */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, DESTRUCTION */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NBELEM : Nombre d'unites demandes */ /* MAXELM : Nombre maxi d'unites disponibles dans ITABLO */ /* ITABLO : Adresse de reference de la zone allouee */ /* IOFSET : Decalage */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* IERCOD : Code d'erreur */ /* = 0 : OK */ /* = 1 : Pb de de-allocation d'une zone allouee sur table */ /* = 2 : Le systeme refuse la demande de de-allocation */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MCRDELT */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* (Cf description dans l'entete de MCRDELT) */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 16-10-91 : DGZ ; Recuperation version FBI */ /* > */ /* *********************************************************************** */ integer iunit; /* Parameter adjustments */ --itablo; iunit = sizeof(integer); /* Function Body */ if (*iofset != 0) { AdvApp2Var_SysBase::mcrdelt_(&iunit, nbelem, (doublereal *)&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, long int *iofset, integer *iercod) { static integer c__8 = 8; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Destruction d'une allocation dynamique de type DOUBLE PRECISION */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, DESTRUCTION */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NBELEM : Nombre d'unites demandes */ /* MAXELM : Nombre maxi d'unites disponibles dans XTABLO */ /* XTABLO : Adresse de reference de la zone allouee */ /* IOFSET : Decalage */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* IERCOD : Code d'erreur */ /* = 0 : OK */ /* = 1 : Pb de de-allocation d'une zone allouee sur table */ /* = 2 : Le systeme refuse la demande de de-allocation */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MCRDELT */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* (Cf description dans l'entete de MCRDELT) */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 16-10-91 : DGZ ; Recuperation version FBI */ /* > */ /* *********************************************************************** */ /* 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_(long int *,//iad, integer *)//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 }; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* ECRITURE D'UNE ADRESSE ECRASEE DANS LES ALLOCS . */ /* MOTS CLES : */ /* ----------- */ /* ALLOC CONTROLE */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* IAD : ADRESSE A SIGNALER ECRASEE */ /* NALLOC : NUMERO DE L'ALLOCATION */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 30-09-91 : DGZ; AJOUT DU NUMERO DE L'ALLOCATION */ /* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS . */ /* 17-05-89 : PP ; CREATION */ /* > */ /* *********************************************************************** */ /* 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_(long int *iadfld, long int *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 long int ioff,iadrfl, iadt; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* MISE EN PLACE DES DEUX FLAGS DE DEBUT ET DE FIN DE LA ZONE */ /* ALLOUEE ET MISE A OVERFLOW DE L'ESPACE UTILISATEUR EN PHASE */ /* DE PRODUCTION. */ /* MOTS CLES : */ /* ----------- */ /* ALLOCATION, CONTROLE, DEBORDEMENT */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* IADFLD : ADRESSE DU FLAG DE DEBUT */ /* IADFLF : ADRESSE DU FLAG DE FIN */ /* IPHASE : TYPE DE VERSION LOGICIELLE : */ /* 0 = VERSION OFFICIELLE */ /* 1 = VERSION PRODUCTION */ /* IZNUTI : TAILLE DE LA ZONE UTILISATEUR EN OCTETS */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* CRLOCT,MACRCHK */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 25-09-91 : DGZ ; GERE LES FLAGS DANS LE COMMUN MCRGENE */ /* 21-08-90 : DGZ ; APPELS DE MACRCHK DANS LES DEUX CAS (AJOUT,SUPP) */ /* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS . */ /* 03-10-89 : DGZ ; REMPLACE COMMON ACFLAG PAR INCLUDE ACFLAG.INC */ /* 09-06-89 : PP ; CORRECTION DU CALCUL DE L'OFFSET */ /* 31-05-89 : DGZ ; OPTIMISATION DE LA GESTION DU TABLEAU DES FLAGS */ /* 23-05-89 : DGZ ; CORRECTION DEBORDEMENT DU TABLEAU ACRTAB */ /* 11-05-89 : DGZ ; CREATION DE LA VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, MEMOIRE, ALLOCATION */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */ /* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */ /* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */ /* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */ /* + AJOUT DE COMMENTAIRES */ /* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */ /* 15-04-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */ /* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */ /* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */ /* 2 : UNITE D'ALLOCATION */ /* 3 : NB D'UNITES ALLOUEES */ /* 4 : ADRESSE DE REFERENCE DU TABLEAU */ /* 5 : IOFSET */ /* 6 : NUMERO ALLOCATION STATIQUE */ /* 7 : Taille demandee en allocation */ /* 8 : adresse du debut de l'allocation */ /* 9 : Taille de la ZONE UTILISATEUR */ /* 10 : ADRESSE DU FLAG DE DEBUT */ /* 11 : ADRESSE DU FLAG DE FIN */ /* 12 : Rang de creation de l'allocation */ /* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */ /* NCORE : NBRE D'ALLOCS EN COURS */ /* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST */ /* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */ /* ----------------------------------------------------------------------* */ if (ifois == 0) { matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L); ifois = 1; } /* CALCUL DE L'ADRESSE DE T */ mcrlocv_((long int)t, (long int *)&iadt); /* CALCUL DE l"OFFSET */ ioff = (*iadfld - iadt) / 8; /* MISE A OVERFLOW DE LA ZONE UTILISATEUR EN CAS DE VERSION PRODUCTION */ if (*iphase == 1 && novfl == 0) { ienr = *iznuti / 8; maoverf_(&ienr, &t[ioff + 1]); } /* MISE A JOUR DU FLAG DE DEBUT */ t[ioff] = -134744073.; /* APPEL BIDON POUR PERMETTRE L'ARRET AU DEBUGGER : */ iadrfl = *iadfld; macrbrk_(); /* MISE A JOUR DU FLAG DE DEBUT */ ioff = (*iadflf - iadt) / 8; t[ioff] = -134744073.; /* APPEL BIDON POUR PERMETTRE L'ARRET AU 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 }; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* MESSAGERIE DES ROUTINES D'ALLOC */ /* MOTS CLES : */ /* ----------- */ /* ALLOC,MESSAGE */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* CROUT : NOM DE LA ROUTINE APPELANTE : MCRRQST, MCRDELT, MCRLIST */ /* ,CRINCR OU CRPROT */ /* NUM : NUMERO DU MESSAGE */ /* IT : TABLEAU DE DONNEES ENTIERES */ /* XT : TABLEAU DE DONNEES REELLES */ /* CT : ------------------ CHARACTER */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* ROUTINE A USAGE TEMPORAIRE, EN ATTENDANT LA 'NOUVELLE' MESSAGERIE */ /* (STRIM 3.3 ?) , POUR RENDRE LES ROUTINES D'ALLOC UTILISABLES */ /* AILLEURS QUE DANS STRIM T-M . */ /* EN FONCTION DE LA LANGUE, ECRITURE DU MESSAGE DEMANDE SUR */ /* L'UNITE IMP . */ /* (REPRISE DES SPECIFS DE VFORMA) */ /* LE MESSAGE EST INITIALISE A 'IL MANQUE LE MESSAGE', ET CELUI-LA */ /* EST REMPLACE PAR LE MESSAGE DEMANDE S'IL EXISTE . */ /* LES MESSAGES FRANCAIS ONT ETE PRIS DANS LA 3.2 LE 26.2.88, ALORS */ /* QUE LES ANGLAIS ONT ETE PRIS DANS ENGUS, ET QUE LES */ /* ALLEMANDS VIENNENT DE LA 312 . */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 4-09-1991 : FCR ; MENAGE */ /* 02-05-88 : PP ; CORRECTION DE SYNTAXE DE FORMAT */ /* 26.2.88 : PP ECRITURE VERSION ORIGINALE . */ /* > */ /* *********************************************************************** */ /* LOCAL : */ /* ----------------------------------------------------------------------* */ /* RECHERCHE DU MESSAGE EN FONCTION DE LA LANGUE , DE LA ROUTINE */ /* CONCERNEE, ET DU NUMERO DE MESSAGE */ /* LECTURE DE LA LANGUE : */ /* Parameter adjustments */ ct -= ct_len; --xt; --it; /* Function Body */ mamdlng_(cln, 3L); /* INUM : TYPE DE MESSAGE : 0 QUE DU TEXTE, 1 1 ENTIER A ECRIRE */ /* -1 MESSAGE INEXISTANT (1 ENTIER ET 1 CHAINE) */ 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); } } } */ /* ----------------------------------------------------------------------* */ /* REALISATION DU WRITE , AVEC OU SANS DONNEES : */ 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 { /* LE MESSAGE N'EXISTE PAS ... */ 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_(integer *,//iadfld, integer *,//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; /* ********************************************************************** */ /* FONCTION : */ /* ---------- */ /* RENVOIE LA TRADUCTION D'UN "NOM LOGIQUE STRIM" DANS LA */ /* "SYNTAXE INTERNE" CORRESPONDANT A UN "LIEU DE RANGEMENT" */ /* MOTS CLES : */ /* ----------- */ /* NOM LOGIQUE STRIM , TRADUCTION */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* CNMLOG : NOM DU "NOM LOGIQUE STRIM" A TRADUIRE */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* CHAINE : ADRESSE DU "LIEU DE RANGEMENT" */ /* LONG : LONGUEUR UTILE DU "LIEU DE RANGEMENT" */ /* IERCOD : CODE D'ERREUR */ /* IERCOD = 0 : OK */ /* IERCOD = 5 : LIEU DE RANGEMENT CORRESPONDANT AU NOM LOGIQUE */ /* INEXISTANT */ /* IERCOD = 6 : TRADUCTION TROP LONGUE POUR LA VARIABLE 'CHAINE' */ /* IERCOD = 7 : ERREUR SEVERE */ /* COMMONS UTILISES : */ /* ---------------- */ /* NEANT */ /* REFERENCES APPELEES : */ /* ----------------------- */ /* GNMLOG, MACHDIM */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* ROUTINE SPECIFIQUE SGI */ /* DANS TOUS LES CAS OU IERCOD EST >0,AUCUN RESULTAT N'EST RENVOYE */ /* NOTION DE "SYNTAXE UTILISATEUR' ET "SYNTAXE INTERNE" */ /* --------------------------------------------------- */ /* LA "SYNTAXE UTILISATEUR" EST LA SYNTAXE DANS LAQUELLE L'UTILISATE UR*/ /* VISUALISE OU DESIGNE UN NOM DE FICHIER OU LE NOM REPERTOIRE AU */ /* COURS D'UNE SESSION DE STRIM100 */ /* LA "SYNTAXE INTERNE" EST LA SYNTAXE UTILISEE POUR EFFECTUER DES */ /* OPERATIONS DE TRAITEMENTS DE FICHIERS A L'INTERIEUR DU CODE */ /* (OPEN,INQUIRE,...ETC) */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 08-01-91 : B. Achispon ; Mise en forme et suppresion appel a MACHDIM */ /* 26-10-88 : C. Guinamard ; Adaptation UNIX Traduction effective */ /* du nom logique */ /* 10-08-88 : DGZ ; CHANGE BNMLOG PAR MATRLOG */ /* 05-02-88 : DGZ ; MODIF D'ENTETE */ /* 26-08-87 : DGZ ; APPEL DE BNMLOG */ /* 25-08-87 : BJ ; MODIF ENTETE */ /* 24-12-86 : DGZ ; CREATION VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ /* DECLARATIONS */ /* *********************************************************************** */ /* *********************************************************************** */ /* TRAITEMENT */ /* *********************************************************************** */ *long__ = 0; *iercod = 0; /* CONTROLE DE L'EXISTENCE DU NOM LOGIQUE */ matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L); if (ier == 1) { goto L9500; } if (ier == 2) { goto L9700; } /* CONTROLE DE LA LONGUEUR DE CHAINE */ if (ibid > __i__len()/*chaine, chaine_len)*/) { goto L9600; } //__s__copy(chaine, cbid, chaine_len, ibid); *long__ = ibid; goto L9999; /* *********************************************************************** */ /* TRAITEMENT DES ERREURS */ /* *********************************************************************** */ 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); /* *********************************************************************** */ /* RETOUR AU PROGRAMME APPELANT */ /* *********************************************************************** */ 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; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* INITIALISATION A UNE VALEUR DONNEE D'UN TABLEAU DE REEL *8 */ /* MOTS CLES : */ /* ----------- */ /* MANIPULATIONS, MEMOIRE, INITIALISATION, DOUBLE-PRECISION */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* ITAILL : TAILLE DU TABLEAU */ /* XTAB : TABLEAU A INITIALISER AVEC XVAL */ /* XVAL : VALEUR A METTRE DANS XTAB(1 A ITAILL) */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* XTAB : TABLEAU INITIALISE */ /* COMMONS UTILISES : */ /* ------------------ */ /* REFERENCES APPELEES : */ /* --------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* ON APPELLE MCRFILL QUI FAIT DES MOVE PAR PAQUETS DE 63 REELS */ /* LE PAQUET INITIAL EST BUFF0 INITE PAR DATA SI LA VALEUR EST 0 */ /* OU BUFFX INITE PAR XVAL (BOUCLE) SINON . */ /* PORTABILITE : OUI */ /* ACCES : LIBRE */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 13-11-1991 : FCR ; VERFOR : Menage */ /* 06-05-91 : DGZ; MODIFICATION EN-TETE */ /* 05-07-88 : PP ; OPTIMISATION PAR POMPAGE SUR MVRMIRAZ */ /* 28-04-88 : PP ; CREATION */ /* > */ /* *********************************************************************** */ /* 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, (char *)buff0, (char *)&xtab[(nufois - 1) * 63 + 1]); /* L1000: */ } } if (nreste >= 1) { i__1 = nreste << 3; AdvApp2Var_SysBase::mcrfill_(&i__1, (char *)buff0, (char *)&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, (char *)buffx, (char *)&xtab[(nufois - 1) * 63 + 1]); /* L3000: */ } } if (nreste >= 1) { i__1 = nreste << 3; AdvApp2Var_SysBase::mcrfill_(&i__1, (char *)buffx, (char *)&xtab[noffst + 1]); } } /* ----------------------------------------------------------------------* */ return 0; } /* maitbr8_ */ //======================================================================= //function : mamdlng_ //purpose : //======================================================================= int mamdlng_(char *,//cmdlng, ftnlen )//cmdlng_len) { /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* RENVOIE LA LANGUE COURANTE */ /* MOTS CLES : */ /* ----------- */ /* GESTION, CONFIGURATION, LANGUE, LECTURE */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* CMDLNG : LANGUE */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* MACETAT */ /* REFERENCES APPELEES : */ /* --------------------- */ /* NEANT */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* DROIT D'UTILISATION : TOUTES APPLICATIONS */ /* ATTENTION : CETTE ROUTINE DEPEND D'UNE INITIALISATION */ /* ---------- PREALABLE FAITE AVEC AMDGEN. */ /* IL CONVIENT DONC DE S'ASSURER QUE CETTE INIT EST */ /* BIEN REALISEE DANS LE OU LES PROGRAMMES CONCERNES */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 25-01-93 : JMB ; NETTOYAGE DE MAMDLNG */ /* 23-03-90 : DGZ ; CORRECTION DE L'EN-TETE */ /* 22-12-89 : DGZ ; CORRECTION DE L'EN-TETE */ /* 22-02-88 : DGZ ; CREATION VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ /* INCLUDE MACETAT */ /* < */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* CONTIENT LES INFORMATIONS RELATIVES A LA COMPOSITION DE */ /* L'EXECUTABLE ET A SON ENVIRONNEMENT : */ /* - LANGUES */ /* - APPLICATIONS PRESENTES */ /* - TYPES D'ENTITES AUORISEES (NON UTILISE) */ /* AINSI QUE DES INFORMATIONS DECRIVANTS L'ETAT COURANT : */ /* - APPLICATION EN COURS */ /* - MODE D'UTILISATION (NON UTILISE) */ /* MOTS CLES : */ /* ----------- */ /* APPLICATION, LANGUE */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* A) CHLANG*4 : LISTE DES VALEURS POSSIBLES DE LA LANGUE : */ /* 'FRA ','DEU ','ENG ' */ /* CHL10N*4 : LISTE DES VALEURS POSSIBLES DE LA LOCALISATION : */ /* 'FRA ','DEU ','ENG ', 'JIS ' */ /* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : APPLICATION COURANTE, PRECEDENTE */ /* ET SUIVANTE */ /* C) CHMODE*4 : MODE COURANT (NON UTILISE) */ /* D) CHPRES*2 (1:NBRMOD) : LISTE DES APPLICATIONS PRISES EN COMPTE */ /* Rang ! Code interne ! Application */ /* ---------------------------------------------------------- */ /* 1 ! CD ! Modelisation 2D */ /* 2 ! CA ! Modelisation 2D par apprentissage */ /* 3 ! CP ! Modelisation 2D parametree */ /* 4 ! PC ! Modelisation rheologique 2D */ /* 5 ! CU ! Fraisage 2 Axes 1/2 */ /* 6 ! CT ! Tournage */ /* 7 ! TS ! Modelisation 3D surfacique */ /* 8 ! TV ! Modelisation 3D volumique */ /* 9 ! MC ! Maillage coque */ /* 10 ! MV ! Maillage volumique */ /* 11 ! TU ! Usinage 3 axes continus */ /* 12 ! T5 ! Usinage 3-5 axes */ /* 13 ! TR ! Usinage 5 axes de surfaces reglees */ /* 14 ! IG ! Interface IGES */ /* 15 ! ST ! Interface SET */ /* 16 ! VD ! Interface VDA */ /* 17 ! IM ! Interface de modelisation */ /* 18 ! GA ! Generateur APT/IFAPT */ /* 19 ! GC ! Generateur COMPACT II */ /* 20 ! GP ! Generateur PROMO */ /* 21 ! TN ! Usinage par copiage numerique */ /* 22 ! GM ! Gestion des modeles */ /* 23 ! GT ! Gestion de trace */ /* ---------------------------------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 05-05-93 : JMB ; Livraison GI93033FGR019 */ /* 8-03-1993: STT ; AJOUT CHL10N */ /* 31-07-92 : FCR ; GI91050G0348 : Suppression de CHTYPE */ /* 18-06-90 : DGZ ; AJOUT EXTENSION PAR COPIAGE NUMERIQUE */ /* 15-03-89 : DGZ ; MODIF DES APPLICATIONS POUR STANDARDS METIERS */ /* 13-09-88 : DGZ ; AJOUT DES MODULES CC (TVCC) ET CG (CA GLOBAL) */ /* 13-09-88 : DGZ ; AJOUT DES MODULES SET, IGES, VDA */ /* 22-02-88 : DGZ ; CREATION VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ /* NOMBRE D'APPLICATIONS PRISES EN COMPTE */ /* NOMBRES DE TYPES D'ENTITE GERES PAR 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; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* AFFICHAGE DU TRACE-BACK EN PHASE DE PRODUCTION */ /* MOTS CLES : */ /* ----------- */ /* FONCTION, SYSTEME, TRACE-BACK, AFFICHAGE, DEBUGGAGE */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NEANT */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* NEANT */ /* COMMONS UTILISES : */ /* ------------------ */ /* NEANT */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MADBTBK */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* CETTE ROUTINE DOIT ETRE APPELE POUR REALISER UN AFFICHAGE */ /* DE TRACE-BACK EN PHASE DE PRODUCTION ET LAISSER QUAND MEME */ /* LA POSSIBILITE AUX TESTEURS D'OBTENIR CES TRACE-BACK DANS */ /* LES VERSIONS CLIENTS SI UNE DES CONTIONS SUIVANTES EST */ /* VERIFIEE : */ /* - EXISTENCE DU SYMBOLE 'STRMTRBK' */ /* - EXISTENCE DU FICHIER 'STRMINIT:STRMTRBK.DAT' */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 26-07-90 : DGZ ; CREATION DE LA VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ 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; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Initialisation en overflow d'un tableau en DOUBLE PRECISION */ /* MOTS CLES : */ /* ----------- */ /* MANIPULATION, MEMOIRE, INITIALISATION, OVERFLOW */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* NBENTR : Nombre d'entrees du tableau */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* DATBLE : Tableau double precision initialise en overflow */ /* COMMONS UTILISES : */ /* ------------------ */ /* R8OVR contenu dans l'include MAOVPAR.INC */ /* REFERENCES APPELEES : */ /* --------------------- */ /* MCRFILL */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* 1) Doc. programmeur : */ /* Cette routine initialise a l'overflow positif un tableau en */ /* DOUBLE PRECISION. */ /* Les autres types de tableaux (INTEGER*2, INTEGER, REAL, ...) */ /* ne sont pas geres par la routine. */ /* Elle est utilisable en phase de developpement pour deceler les */ /* erreurs d'initialisation. */ /* En version officielle, ses appels seront desactives. */ /* ACCES : Sur accord avec AC. */ /* La routine ne renvoie pas de code d'erreur. */ /* L'argument NBELEM doit etre positif. */ /* S'il est negatif ou nul, affichage du message "MAOVERF : NBELEM = */ /* valeur_de_NBELEM" et d'un Trace Back par l'appel a la routine */ /* MAOSTRB. */ /* 2) Doc. concepteur : */ /* L'idee est de minimiser le nombre d'appels a */ /* la routine de transfert de zones numeriques, */ /* ---------- pour des raisons de performances. */ /* ! buffer ! Pour cela, on se reserve un tableau de NLONGR */ /* !__________! DOUBLE PRECISIONs. Ce buffer est initialise par */ /* <----------> l'instruction DATA. L'overflow est accede dans un */ /* NLONGR*8 COMMON specifique et non par une routine car */ /* l'initialisation se fait par DATA. */ /* * Si NBENTR */ /* *********************************************************************** */ /* Inclusion de MAOVPAR.INC */ /* CONSTANTES */ /* INCLUDE MAOVPAR */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* DEFINIT LES VALEURS LIMITES SPECIFIQUES MACHINE. */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, LIMITES, VALEURS, SPECIFIQUE */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* *** ELLES NE PEUVENT PAS ETRE ECRASEES EN COURS D'EXECUTION. */ /* *** LES VALEURS D'UNDERFLOW ET D'OVERFLOW NE PEUVENT PAS ETRE */ /* DEFINIES EN VALEUR DECIMALES (ERREUR A LA COMPILATION D_FLOAT) */ /* ON LES DEFINIT DONC EN VALEUR HEXADECIMALES */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 02-02-1993 : JMB ; SUPPRESSION DE LA SPECIFICITE DE L'INCLUDE */ /* 29-08-1990 : DGZ ; AJOUT DES REELS X4OVR ET X4UND */ /* 10-08-1990 : DGZ ; AJOUT DES FORMATS FRMR4,FRMR8,FRMR8G */ /* 18-06-1990 : CS/DGZ ; CREATION VERSION ORIGINALE */ /* > */ /* *********************************************************************** */ /* DECLARATION DU COMMON POUR LES TYPES NUMERIQUES */ /* DECLARATION DU COMMON POUR LES TYPES CARACTERES */ /* VARIABLES LOCALES */ /* TABLEAUX */ /* DATAS */ /* Parameter adjustments */ --dtable; /* Function Body */ /* vJMB R8OVR n est pas encore initialise, donc impossible d utiliser DATA */ /* DATA BUFF / NLONGR * R8OVR / */ /* l init de BUFF n est faite qu'une fois */ 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, (char *)buff, (char *)&dtable[1]); } else { /* Amorce & initialisations */ ioct = 504; AdvApp2Var_SysBase::mcrfill_(&ioct, (char *)buff, (char *)&dtable[1]); indic = 63; /* Boucle. La borne sup. est la valeur entiere du logarithme de base 2 */ /* de NBENTR/NLONGR. */ i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.)) ; for (ibid = 1; ibid <= i__1; ++ibid) { AdvApp2Var_SysBase::mcrfill_(&ioct, (char *)&dtable[1], (char *)&dtable[indic + 1]); ioct += ioct; indic += indic; /* L10: */ } nrest = ( *nbentr - indic ) << 3; if (nrest > 0) { AdvApp2Var_SysBase::mcrfill_(&nrest, (char *)&dtable[1], (char *)&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]; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* RECUPERE LA VALEUR D'UN SYMBOLE DEFINI AU MOMENT DE */ /* L'INITIALISATION D'UN UTILISATEUR */ /* MOTS CLES : */ /* ----------- */ /* TRADUCTION, SYMBOLE */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* CNMSYM : NOM DU SYMBOLE */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* CHAINE : TRADUCTION DU SYMBOLE */ /* LENGTH : LONGUEUR UTILE DE LA CHAINE */ /* IERCOD : CODE D'ERREUR */ /* = 0 : OK */ /* = 1 : SYMBOLE INEXISTANT */ /* = 2 : AUTRE ERREUR */ /* COMMONS UTILISES : */ /* ------------------ */ /* NEANT */ /* REFERENCES APPELEES : */ /* --------------------- */ /* LIB$GET_SYMBOL,MACHDIM */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* - CETTE ROUTINE EST SPECIFIQUE VAX */ /* - EN CAS D'ERREUR (IERCOD>0), CHAINE = ' ' ET LENGTH = 0 */ /* - SI LA VARIABLE D'ENTREE CNMSYM EST VIDE, LA ROUTINE RENVOIE IERC OD=1*/ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* SGI_H 16-04-91 : CSO ; CORRECTION CAS SYMBOLE INEXISTANT ==> IERCOD=1 */ /* SGI_ 07-01-91 : SVN ; MODIF IERCOD NE DOIT PAS DEPASSER 2 */ /* CHAINEVIDE VAUT CARACTERE BLANC */ /* 22-02-88 : DGZ ; CREATION DE LA VERSION ORIGINALE */ /* 07-09-88 : SGI_H : CS; SOUS UNIX SYMBOLE=NOM LOGIQUE = VARIABLE */ /* ==> idem MAGTLOG */ /* > */ /* *********************************************************************** */ /* 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...^ */ /* *********************************************************************** */ /* TRAITEMENT DES ERREURS */ /* *********************************************************************** */ /* L9999: */ return 0; } /* matrsym_ */ //======================================================================= //function : mcrcomm_ //purpose : //======================================================================= int mcrcomm_(integer *kop, integer *noct, long int *iadr, integer *ier) { /* Initialized data */ static integer ntab = 0; /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer ideb; static doublereal dtab[32000]; static long int itab[160] /* was [4][40] */; static integer ipre, i__, j, k; /************************************************************************ *******/ /* FONCTION : */ /* ---------- */ /* ALLOCATION DYNAMIQUE SUR COMMON */ /* MOTS CLES : */ /* ----------- */ /* . ALLOCDYNAMIQUE,MEMOIRE,COMMON,ALLOC */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */ /* NOCT : NOMBRE D'OCTETS */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* IADR : ADRESSE EN MEMOIRE DU PREMIER OCTET */ /* * : */ /* * : */ /* IERCOD : CODE D'ERREUR */ /* IERCOD = 0 : OK */ /* IERCOD > 0 : ERREUR GRAVE */ /* IERCOD < 0 : WARNING */ /* IERCOD = 1 : DESCRIPTION DE L'ERREUR */ /* IERCOD = 2 : DESCRIPTION DE L'ERREUR */ /* COMMONS UTILISES : */ /* ---------------- */ /* CRGEN2 */ /* REFERENCES APPELEES : */ /* ---------------------- */ /* Type Name */ /* MCRLOCV */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* ATTENTION .... ITAB ET NTAB NE SONT PAS SAUVEGARDES ENTRE 2 APPELS.. */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS. */ /* 16-05-89 : DGZ; SUPPRESSION DU COMMON CRGEN2 */ /* 02-05-88 : PP ; AJOUT DE COMMENTAIRES */ /* 20-01-88 : JPF; MAXCOM DE 500 --> 250 */ /* 09-12-85 : BF ; UTILISE LES ROUTINES STANDARDS */ /* 08-11-85 : BF ; BUG SUR DEPLACEMENT TROU */ /* 07-11-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */ /* ITAB : TABLE DE GESTION DE DTAB, ZONE DE MEMOIRE ALLOUABLE . */ /* NTAB : NOMBRE D'ALLOCS REALISEES . */ /* FORMAT DE ITAB : NOMBRE DE REAL*8 ALLOUES , ADRESSE DU 1ER REAL*8 */ /* , NOCT , ADRESSE VIRTUELLE */ /* PP COMMON / CRGEN2 / DTAB */ /* ----------------------------------------------------------------------* */ *ier = 0; /* ALLOCATION : RECHERCHE D'UN TROU */ 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) { /* ON A TROUVE UN TROU */ 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_((long int)&dtab[ipre - 1], (long int *)iadr); itab[(i__ << 2) - 1] = *iadr; goto L9900; } /* L1001: */ } /* PAS DE TROU */ *ier = 3; goto L9900; /* ----------------------------------- */ /* DESTRUCTION DE L'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; } /* ON A TROUVE L'ALLOCATION A SUPPRIMER */ 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: ; } /* L'ALLOCATION N'EXISTE PAS */ *ier = 4; /* PP GOTO 9900 */ } L9900: return 0; } /* mcrcomm_ */ //======================================================================= //function : AdvApp2Var_SysBase::mcrdelt_ //purpose : //======================================================================= int AdvApp2Var_SysBase::mcrdelt_(integer *iunit, integer *isize, doublereal *t, long int *iofset, integer *iercod) { static integer ibid; static doublereal xbid; static integer noct, iver, ksys, i__, n, nrang, ibyte, ier; static long int iadfd, iadff, iaddr, loc; /* Les adrresses en long*/ static integer kop; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* DESTRUCTION D'UNE ALLOCATION DYNAMIQUE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, DESTRUCTION */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* IUNIT : NOMBRE D'OCTETS DE L'UNITE D'ALLOCATION */ /* ISIZE : NOMBRE D'UNITES DEMANDEES */ /* T : ADRESSE DE REFERENCE */ /* IOFSET : DECALAGE */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* IERCOD : CODE D'ERREUR */ /* = 0 : OK */ /* = 1 : PB DE DE-ALLOCATION D'UNE ZONE ALLOUEE EN COMMON */ /* = 2 : LE SYSTEME REFUSE LA DEMANDE DE DE-ALLOCATION */ /* = 3 : L'ALLOCATION A DETRUIRE N'EXISTE PAS. */ /* COMMONS UTILISES : */ /* ---------------- */ /* REFERENCES APPELEES : */ /* ---------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* 1) UTILISATEUR */ /* ----------- */ /* MCRDELT FAIT UNE LIBERATION DE ZONE MEMOIRE ALLOUEE */ /* PAR LA ROUTINE MCRRQST (OU CRINCR) */ /* LA SIGNIFICATION DES ARGUMENTS EST LA MEME QUE MCRRQST */ /* *** ATTENTION : */ /* ----------- */ /* IERCOD=2 : CAS OU LE SYSTEME NE PEUT LIBERER LA MEMOIRE ALLOUEE, */ /* LE MESSAGE SUIVANT APPARAIT SYSTEMATIQUEMENT SUR LA CONSOLE */ /* ALPHA : */ /* "Le systeme refuse une destruction d'allocation de memoire" */ /* IERCOD=3 CORRESPOND AU CAS OU LES ARGUMENTS SONT MAUVAIS */ /* (ILS NE PERMETTENT PAS DE RECONNAITRE L'ALLOCATION DANS LA TABLE) */ /* Lorsque l'allocation est detruite, l'IOFSET correspondant est mis */ /* a 2 147 483 647. Ainsi, si on accede au tableau via l'IOFSET, un */ /* trap se produira. Ceci permet de verifier qu'on ne se sert plus */ /* d'une zone de memoire qu'on a liberee. Cette verification n'est */ /* valable que si c'est le meme sous-programme qui utilise et qui */ /* detruit l'allocation. */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 05-03-93 : FCR : DMSF52088 : On prend les memes et on recommence ... */ /* IERCOD = 3 et I4UND. */ /* 22-02-93 : FCR : Pour TOYOTA : Desactivation de l'affectation de */ /* l'IOFSET a I4UND et suppression de IERCOD = 3. */ /* 10-02-93 : FCR ; DMSFRO253 : Ajout d'un appel a MAERMSG si IERCOD */ /* = 3 */ /* 22-01-93 : FCR ; DMSF52088 : Ajout de l'IERCOD 3. */ /* Ajout de l'IOFSET mis a I4UND lorsque */ /* l'allocation est detruite. */ /* 08-10-92 : FCR ; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 08-09-92 : FCR ; Optimisation */ /* 18-11-91 : DGZ ; APPEL MACRCHK EN PHASE DE DEVELOPPEMENT */ /* 23-09-91 : DGZ ; RENOMME EN .FOR ET MODIFS DE COMMENTAIRES */ /* 14-05-91 : DGZ ; SUPPRIME L'OPTION /CHECK=NBOUNDS */ /* 21-08-90 : DGZ ; AFFICHAGE DU TRACE-BACK EN PHASE DE PRODUCTION */ /* ET RENOMME EN .VAX */ /* 22-12-89 : DGZ ; CORRECTION DE L'EN-TETE */ /* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS. */ /* 11-05-89 : DGZ; CONTROLE DEBORDEMENT DE MEMOIRE */ /* 27-06-88 : PP ; VIRE 9001 INUTILISE */ /* PP 26.2.88 CHANGE LE VFORMA EN MACRMSG, POUR USAGE DANS C */ /* 09-01-87 : BF ; ALLOCATIONS SYSTEME */ /* 03-11-86 : BF ; RAJOUTE STATISTIQUES */ /* 09-12-85 : BF ; UTILISE LES ROUTINES STANDARDS */ /* 09-12-85 : BF ; PLUS D'ERREUR SI L'ALLOCATION N'EXISTE PAS */ /* 07-11-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* COMMON DES PARAMETRES */ /* COMMON DES STATISTIQUES */ /* INCLUDE MCRGENE */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, MEMOIRE, ALLOCATION */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */ /* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */ /* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */ /* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */ /* + AJOUT DE COMMENTAIRES */ /* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */ /* 15-04-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */ /* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */ /* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */ /* 2 : UNITE D'ALLOCATION */ /* 3 : NB D'UNITES ALLOUEES */ /* 4 : ADRESSE DE REFERENCE DU TABLEAU */ /* 5 : IOFSET */ /* 6 : NUMERO ALLOCATION STATIQUE */ /* 7 : Taille demandee en allocation */ /* 8 : adresse du debut de l'allocation */ /* 9 : Taille de la ZONE UTILISATEUR */ /* 10 : ADRESSE DU FLAG DE DEBUT */ /* 11 : ADRESSE DU FLAG DE FIN */ /* 12 : Rang de creation de l'allocation */ /* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */ /* NCORE : NBRE D'ALLOCS EN COURS */ /* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST */ /* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */ /* ----------------------------------------------------------------------* */ /* 20-10-86 : BF ; VERSION D'ORIGINE */ /* NRQST : NOMBRE D'ALLOCATIONS EFFECTUEES */ /* NDELT : NOMBRE DE LIBERATIONS EFFECTUEES */ /* NBYTE : NOMBRE TOTAL D'OCTETS DES ALLOCATIONS */ /* MBYTE : NOMBRE MAXI D'OCTETS */ /* Parameter adjustments */ --t; /* Function Body */ *iercod = 0; /* RECHERCHE DANS MCRGENE */ n = 0; mcrlocv_((long int)&t[1], (long int *)&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: /* SI L'ALLOCATION N'EXISTE PAS , ON SORT */ if (n <= 0) { goto L9003; } /* ALLOCATION RECONNUE : ON RECUPERE LES AUTRES INFOS */ ksys = mcrgene_.icore[n * 12 - 7]; ibyte = mcrgene_.icore[n * 12 - 6]; iaddr = mcrgene_.icore[n * 12 - 5]; iadfd = mcrgene_.icore[n * 12 - 3]; iadff = mcrgene_.icore[n * 12 - 2]; nrang = mcrgene_.icore[n * 12 - 1]; /* Controle des flags */ madbtbk_(&iver); if (iver == 1) { macrchk_(); } if (ksys <= 1) { /* DE-ALLOCATION SUR COMMON */ kop = 2; mcrcomm_(&kop, &ibyte, &iaddr, &ier); if (ier != 0) { goto L9001; } } else { /* DE-ALLOCATION SYSTEME */ mcrfree_((integer *)&ibyte, (uinteger *)&iaddr, (integer *)&ier); if (ier != 0) { goto L9002; } } /* APPEL PERMETTANT LE CANCEL WATCH AUTOMATQUE PAR LE DEBUGGER */ macrclw_(&iadfd, &iadff, &nrang); /* MISE A JOUR DES STATISTIQUES */ if (ksys <= 1) { i__ = 1; } else { i__ = 2; } ++mcrstac_.ndelt[i__ - 1]; mcrstac_.nbyte[i__ - 1] -= mcrgene_.icore[n * 12 - 11] * mcrgene_.icore[n * 12 - 10]; /* SUPPRESSION DES PARAMETRES DANS MCRGENE */ if (n < 1000) { /* noct = (mcrgene_1.ncore - n) * 48; */ noct = (mcrgene_.ncore - n) * 12 * sizeof(long int); AdvApp2Var_SysBase::mcrfill_((integer *)&noct, (char *)&mcrgene_.icore[(n + 1) * 12 - 12], (char *)&mcrgene_.icore[n * 12 - 12]); } --mcrgene_.ncore; /* *** Mise a l'overflow de l'IOFSET */ *iofset = 2147483647; goto L9900; /* ----------------------------------------------------------------------* */ /* TRAITEMENT DES ERREURS */ L9001: /* REFUS DE DE-ALLOCATION PAR LA ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */ *iercod = 1; AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L); maostrd_(); goto L9900; /* REFUS DE DE-ALLOCATION PAR LE SYSTEME */ L9002: *iercod = 2; AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L); macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L); maostrd_(); goto L9900; /* ALLOCATION INEXISTANTE */ L9003: *iercod = 3; AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L); maostrd_(); goto L9900; L9900: return 0 ; } /* mcrdelt_ */ /* C********************************************************************* C C FONCTION : C ---------- C Transfert une zone memoire dans une autre en gerant les C recouvrements C C MOTS CLES : C ----------- C MANIPULATION, MEMOIRE, TRANSFERT, CARACTERE C C ARGUMENTS D'ENTREE : C ------------------ C nb_car : integer*4 nombre de caracteres a transferer. C source : zone memoire source. C C ARGUMENTS DE SORTIE : C ------------------- C dest : zone memeoire destination. C C COMMONS UTILISES : C ---------------- C C REFERENCES APPELEES : C ------------------- C C DEMSCRIPTION/REMARQUES/LIMITATIONS : C ----------------------------------- C Routine portable UNIX (SGI, ULTRIX, BULL) C C$ HISTORIQUE DES MODIFICATIONS : C ---------------------------- C 24/01/92 : DGZ ; Recuperation de la version BULL C> C********************************************************************** */ //======================================================================= //function : AdvApp2Var_SysBase::mcrfill_ //purpose : //======================================================================= int AdvApp2Var_SysBase::mcrfill_(integer *size, char *tin, char *tout) { if (mcrfill_ABS(tout-tin) >= *size) memcpy( tout, tin, *size); else if (tin > tout) { register integer n = *size; register char *jmin=tin; register char *jmout=tout; while (n-- > 0) *jmout++ = *jmin++; } else { register integer n = *size; register char *jmin=tin+n; register char *jmout=tout+n; while (n-- > 0) *--jmout = *--jmin; } return 0; } /*........................................................................*/ /* */ /* FONCTION : */ /* ---------- */ /* Routines de gestion de la memoire dynamique. */ /* */ /* Routine mcrfree */ /* -------------- */ /* */ /* Desallocation d'une zone memoire. */ /* */ /* CALL MCRFREE (IBYTE,IADR,IER) */ /* */ /* IBYTE INTEGER*4 : Nombre d'Octetes a Liberer */ /* */ /* IADR POINTEUR : Adresse de Depart */ /* */ /* IER INTEGER*4 : Code de Retour */ /* */ /* */ /* MOTS CLES : */ /* ----------- */ /* */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* */ /* COMMONS UTILISES : */ /* ------------------ */ /* */ /* REFERENCES APPELEES : */ /* --------------------- */ /* */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* */ /* ** SPECIFIQUE SPS9 ** */ /* */ /* */ /* HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* */ /* 07-03-86 : FS; INSERTION DE L'ENTETE STANDARD C */ /* 16-09-86 : FS; MODIFICATIONS PASSAGE NIVEAU INFERIEUR */ /* SGI_H 05-04-90 : ACT ; ECLATEMENT DU PACKAGE CRALOC */ /* */ /*........................................................................*/ /* */ //======================================================================= //function : mcrfree_ //purpose : //======================================================================= int mcrfree_(integer *,//ibyte, uinteger *iadr, integer *ier) { *ier=0; free((void*)*iadr); if ( !*iadr ) *ier = 1; return 0; } /*........................................................................*/ /* */ /* FONCTION : */ /* ---------- */ /* Routines de gestion de la memoire dynamique. */ /* */ /* Routine mcrgetv */ /* -------------- */ /* */ /* Demande d'allocation de memoire. */ /* */ /* CALL MCRGETV(IBYTE,IADR,IER) */ /* */ /* IBYTE (INTEGER*4) Nombre de Bytes d'allocation */ /* demandee */ /* */ /* IADR (INTEGER*4) : Resultat. */ /* */ /* IER (INTEGER*4) : Code d'erreur : */ /* */ /* = 0 ==> OK */ /* = 1 ==> Allocation impossible */ /* = -1 ==> Ofset > 2**31 - 1 */ /* */ /* MOTS CLES : */ /* ----------- */ /* */ /* ARGUMENTS D'ENTREE : */ /* -------------------- */ /* */ /* ARGUMENTS DE SORTIE : */ /* --------------------- */ /* */ /* COMMONS UTILISES : */ /* ------------------ */ /* */ /* REFERENCES APPELEES : */ /* --------------------- */ /* */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* */ /* ** SPECIFIQUE SPS9 ** */ /* */ /* */ /* HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* */ /* 07-03-86 : FS; INSERTION DE L'ENTETE STANDARD C */ /* 16-09-86 : FS; MODIFICATIONS PASSAGE NIVEAU INFERIEUR */ /*SGI_H 05-04-90 : ACT ; ECLATEMENT DU PACKAGE CRALOC */ /* */ /*........................................................................*/ //======================================================================= //function : mcrgetv_ //purpose : //======================================================================= int mcrgetv_(integer *sz, uinteger *iad, integer *ier) { *ier = 0; *iad = (uinteger)malloc(*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]; /************************************************************************ *******/ /* FONCTION : */ /* ---------- */ /* IMPRESSION DU TABLEAU DES ALLOCATIONS DYNAMIQUES EN COURS */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, LISTE */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* . NEANT */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* * : */ /* * : */ /* IERCOD : CODE D'ERREUR */ /* IERCOD = 0 : OK */ /* IERCOD > 0 : ERREUR GRAVE */ /* IERCOD < 0 : WARNING */ /* IERCOD = 1 : DESCRIPTION DE L'ERREUR */ /* IERCOD = 2 : DESCRIPTION DE L'ERREUR */ /* COMMONS UTILISES : */ /* ---------------- */ /* MCRGENE VFORMT */ /* REFERENCES APPELEES : */ /* ---------------------- */ /* Type Name */ /* VFORMA */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* . NEANT */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 04-08-92 : HCE ; CORRECTION CTLCODE */ /* 10-06-92 : FCR ; CORRECTION CTLCODE */ /* 16-09-1991: FCR ; Suppression INCLUDE VFORMT */ /* 22-12-89 : DGZ ; CORRECTION DE L'EN-TETE */ /* PP 26.2.88 MIS VFORMA A LA PLACE DE MCRLIST */ /* 04-11-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* INCLUDE MCRGENE */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, MEMOIRE, ALLOCATION */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */ /* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */ /* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */ /* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */ /* + AJOUT DE COMMENTAIRES */ /* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */ /* 15-04-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */ /* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */ /* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */ /* 2 : UNITE D'ALLOCATION */ /* 3 : NB D'UNITES ALLOUEES */ /* 4 : ADRESSE DE REFERENCE DU TABLEAU */ /* 5 : IOFSET */ /* 6 : NUMERO ALLOCATION STATIQUE */ /* 7 : Taille demandee en allocation */ /* 8 : adresse du debut de l'allocation */ /* 9 : Taille de la ZONE UTILISATEUR */ /* 10 : ADRESSE DU FLAG DE DEBUT */ /* 11 : ADRESSE DU FLAG DE FIN */ /* 12 : Rang de creation de l'allocation */ /* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */ /* NCORE : NBRE D'ALLOCS EN COURS */ /* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST */ /* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */ /* ----------------------------------------------------------------------* */ /* ----------------------------------------------------------------------* */ *ier = 0; //__s__copy(subrou, "MCRLIST", 7L, 7L); /* ECRITURE DE L'EN TETE */ 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 = 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_(long int t, long int *l) { *l = t; return 0 ; } //======================================================================= //function : AdvApp2Var_SysBase::mcrrqst_ //purpose : //======================================================================= int AdvApp2Var_SysBase::mcrrqst_(integer *iunit, integer *isize, doublereal *t, long int *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 long int iadfd, iadff, iaddr,lofset, loc; static integer izu; /* ********************************************************************** */ /* FONCTION : */ /* ---------- */ /* REALISATION D'UNE ALLOCATION DYNAMIQUE DE MEMOIRE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, ALLOCATION, MEMOIRE, REALISATION */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* IUNIT : NOMBRE D'OCTEST DE L'UNITE D'ALLOCATION */ /* ISIZE : NOMBRE D'UNITES DEMANDEES */ /* T : ADRESSE DE REFERENCE */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* IOFSET : DECALAGE */ /* IERCOD : CODE D'ERREUR, */ /* = 0 : OK */ /* = 1 : NBRE MAXI D'ALLOCS ATTEINT */ /* = 2 : ARGUMENTS INCORRECTS */ /* = 3 : REFUS D'ALLOCATION DYNAMIQUE */ /* COMMONS UTILISES : */ /* ---------------- */ /* MCRGENE, MCRSTAC */ /* REFERENCES APPELEES : */ /* ----------------------- */ /* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* 1) UTILISATEUR */ /* -------------- */ /* T EST L'ADRESSE D'UN TABLEAU BANAL,IOFSET REPRESENTE LE DEPLACEMENT EN */ /* UNITES DE IUNIT OCTETS ENTRE LA ZONE ALLOUEE ET LE TABLEAU T */ /* IERCOD=0 SIGNALE QUE L'ALLOCATION S'EST BIEN DEROULEE ,TOUTE AUTRE */ /* VALEUR INDIQUE UNE ANOMALIE. */ /* EXEMPLE : */ /* SOIT LA DECLARATION REAL*4 T(1), DONC IUNIT=4 . */ /* L'APPEL A MCRRQST FAIT UNE ALLOCATION DYNAMIQUE */ /* ET DONNE UNE VALEUR A LA VARIABLE IOFSET, */ /* SI L'ON VEUT ECRIRE 1. DANS LA CINQUIEME ZONE REAL*4 */ /* AINSI ALLOUEE ,FAIRE: */ /* T(5+IOFSET)=1. */ /* CAS D'ERREURS : */ /* --------------- */ /* IERCOD=1 : NOMBRE MAXI D'ALLOCATION ATTEINT (ACTUELLEMENT 200) */ /* ET LE MESSAGE SUIVANT APPARAIT SUR LA CONSOLE ALPHA : */ /* "Le nombre maxi d'allocation de memoire est atteint : ,N" */ /* IERCOD=2 : ARGUMENT IUNIT INCORRECT CAR DIFFERENT DE 1,2,4 OU 8 */ /* ET LE MESSAGE SUIVANT APPARAIT SUR LA CONSOLE ALPHA : */ /* "Unite d'allocation invalide : ,IUNIT" */ /* IERCOD=3 : REFUS D'ALLOCATION DYNAMIQUE (PLUS DE PLACE MEMOIRE) */ /* ET LE MESSAGE SUIVANT APPARAIT SUR LA CONSOLE ALPHA : */ /* "Le systeme refuse une allocation dynamique de memoire de N octets" */ /* AVEC UN AFFICHAGE COMPLET DE TOUTES LES ALLOCATIONS EFFECTUEES */ /* JUSQU'A PRESENT. */ /* 2) CONCEPTEUR */ /* -------------- */ /* MCRRQST FAIT UNE ALLOCATION DYNAMIQUE DE MEMOIRE VIRTUELLE SUR LA BASE */ /* D'ENTITES DE 8 OCTETS (QUADWORDS) ,BIEN QUE L'ALLOCATION SOIT DEMANDEE */ /* PAR UNITES DE IUNIT OCTETS (1,2,4,8). */ /* LA QUANTITE DEMANDEE EST IUNIT*ISIZE OCTETS,CETTE VALEUR EST ARRONDIE */ /* POUR QUE L'ALLOCATION SOIT UN NOMBRE ENTIER DE QUADWORDS. */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 14-04-94 : JMB; Suppression message ALLOC < 16 octets */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 23-09-91 : DGZ; REND LA ROUTINE PORTABLE */ /* 22-08-90 : DGZ; CORRECTION DE L'EN-TETE */ /* 21-08-90 : DGZ; AFFICHAGE DU TRACE_BACK EN PHASE DE PRODUCTION */ /* 22-12-89 : DGZ; CORRECTION DE L'EN-TETE */ /* 19-05-89 : DGZ; AJOUT DOUBLE MOT SI DECALAGE ET SUPP APPEL ACRVRF */ /* 17-05-89 : DGZ; CALCUL DE IOFSET DANS LE CAS OU IL EST NEGATIF */ /* 11-05-89 : DGZ; CONTROLE DES ECRASEMENTS DE ZONE MEMOIRE */ /* 04-05-88 : PP ; CHANGE MOVFLW EN MAOVERF */ /* 23-03-88 : PP ; CORR DE PASSAGES D'ARGUMENTS DANS MACRMSG ET MOVFLW */ /* 26.2.88 PP VIRE VFORMA, ET MIS MACRMSG */ /* 22.2.88 : PP : CHANGE I*4 EN I ET R*8 EN D P, AJOUT DE ISYST */ /* ,ET VIRE LE TEST SUR IBB, A REMETTRE AVANT LIVRAISON */ /* 09-10-1987 : Initialisation a OVERFLOW si IBB <> 0 JJM */ /* 10-04-87 : BF ; ALLOCATIONS CADREES SUR DOUBLES MOTS */ /* 07-11-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* COMMON DES PARAMETRES */ /* COMMON DES INFORMATIONS SUR LES STATISTIQUES */ /* INCLUDE MCRGENE */ /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */ /* MOTS CLES : */ /* ----------- */ /* SYSTEME, MEMOIRE, ALLOCATION */ /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* ------------------------------ */ /* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */ /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */ /* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */ /* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */ /* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */ /* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */ /* + AJOUT DE COMMENTAIRES */ /* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */ /* 15-04-85 : BF ; VERSION D'ORIGINE */ /* > */ /* *********************************************************************** */ /* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */ /* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */ /* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */ /* 2 : UNITE D'ALLOCATION */ /* 3 : NB D'UNITES ALLOUEES */ /* 4 : ADRESSE DE REFERENCE DU TABLEAU */ /* 5 : IOFSET */ /* 6 : NUMERO ALLOCATION STATIQUE */ /* 7 : Taille demandee en allocation */ /* 8 : adresse du debut de l'allocation */ /* 9 : Taille de la ZONE UTILISATEUR */ /* 10 : ADRESSE DU FLAG DE DEBUT */ /* 11 : ADRESSE DU FLAG DE FIN */ /* 12 : Rang de creation de l'allocation */ /* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */ /* NCORE : NBRE D'ALLOCS EN COURS */ /* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST */ /* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */ /* ----------------------------------------------------------------------* */ /* 20-10-86 : BF ; VERSION D'ORIGINE */ /* NRQST : NOMBRE D'ALLOCATIONS EFFECTUEES */ /* NDELT : NOMBRE DE LIBERATIONS EFFECTUEES */ /* NBYTE : NOMBRE TOTAL D'OCTETS DES ALLOCATIONS */ /* MBYTE : NOMBRE MAXI D'OCTETS */ /* ----------------------------------------------------------------------* */ /* Parameter adjustments */ --t; /* Function Body */ *iercod = 0; if (mcrgene_.ncore >= 1000) { goto L9001; } if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) { goto L9002; } /* Calcul de la taille demandee par l'utilsateur */ ibyte = *iunit * *isize; /* Recheche le type de version (Phase de Production ou Version Client) */ madbtbk_(&iver); /* Controle sur la taille allouee en phase de Production */ if (iver == 1) { if (ibyte == 0) { //s__wsle(&io___3); //do__lio(&c__9, &c__1, "Demande d'allocation nulle", 26L); AdvApp2Var_SysBase::e__wsle(); maostrb_(); } else if (ibyte >= 4096000) { //s__wsle(&io___4); //do__lio(&c__9, &c__1, "Demande d'allocation superieure a 4 Mega-Octets : ", 50L); //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer)); AdvApp2Var_SysBase::e__wsle(); maostrb_(); } } /* ON CALCUL LA TAILLE DE LA ZONE UTILSATEUR (IZU) */ /* . ajout taille demandee par l'utilisateur (IBYTE) */ /* . ajout d'un delta pour alignement avec la base */ /* . on arrondit au multiple de 8 superieur */ mcrlocv_((long int)&t[1], (long int *)&loc); izu = ibyte + loc % *iunit; irest = izu % 8; if (irest != 0) { izu = izu + 8 - irest; } /* ON CALCUL LA TAILLE QUI VA ETRE DEMANDEE A LA PRIMITIVE D'ALLOC */ /* . ajout de la taille de la zone utilisateur */ /* . ajout de 8 pour un alignement de l'adresse de debut */ /* d'allocation sur un multiple de 8 de facon a pouvoir */ /* poser des flags en Double Precision sans pb d'alignement */ /* . ajout de 16 octets pour les deux flags */ ibyte = izu + 24; /* DEMANDE D'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_((integer *)&ibyte, (uinteger *)&iaddr, (integer *)&ier); if (ier != 0) { goto L9003; } /* ENDIF */ /* CALCUL DES ADRESSES DES FLAGS */ iadfd = iaddr + 8 - iaddr % 8; iadff = iadfd + 8 + izu; /* CALCUL DE L'OFFSET UTILISATEUR : */ /* . difference entre l'adresse de depart utilisateur et */ /* l'adresse de la base */ /* . convertit cette difference dans l'unite utilisateur */ lofset = iadfd + 8 + loc % *iunit - loc; *iofset = lofset / *iunit; /* Si phase de production alors controle des flags */ if (iver == 1) { macrchk_(); } /* MISE EN PLACE DES FLAGS */ /* . le premier flag est mis en IADFD et le second en IADFF */ /* . Si phase de production alors on met a overflow la ZU */ macrgfl_(&iadfd, &iadff, &iver, &izu); /* RANGEMENT DES PARAMETRES DANS 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; /* APPEL PERMETTANT UNE MISE EN PLACE AUTO DU SET WATCH PAR LE DEBUGGER */ macrstw_((integer *)&iadfd, (integer *)&iadff, (integer *)&mcrgene_.ncore); /* STATISTIQUES */ ++mcrstac_.nrqst[ksys - 1]; mcrstac_.nbyte[ksys - 1] += 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] = max(i__1,i__2); goto L9900; /* ----------------------------------------------------------------------* */ /* TRAITEMENT DES ERREURS */ /* NBRE MAXI D'ALLOC ATTEINT : */ L9001: *iercod = 1; ifmt = 1000; //__s__copy(subr, "MCRRQST", 7L, 7L); macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L); maostrd_(); goto L9900; /* AURGUMENTS INCORRECTS */ L9002: *iercod = 2; ifmt = *iunit; //__s__copy(subr, "MCRRQST", 7L, 7L); macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L); goto L9900; /* LE SYSTEME REFUSE L'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 FONCTION : CALL MIRAZ(LENGTH,ITAB) C ---------- C C EFFECTUE UNE REMISE A ZERO D'UN TABLEAU DE LOGICAL OU D'INTEGER. C C MOTS CLES : C ----------- C RAZ INTEGER C C ARGUMENTS D'ENTREE : C ------------------ C LENGTH : NOMBRE D'OCTETS A TRANSFERER C ITAB : NOM DU TABLEAU C C ARGUMENTS DE SORTIE : C -------------------- C ITAB : NOM DU TABLEAU REMIS A ZERO C C COMMONS UTILISES : C ---------------- C C REFERENCES APPELEES : C ----------------------- C C DEMSCRIPTION/REMARQUES/LIMITATIONS : C ----------------------------------- C C Portable VAX-SGI C C$ HISTORIQUE DES MODIFICATIONS : C -------------------------------- C C 05-04-93 : JMB ; portabilite VAX SGI C 06-01-86 : FS,GFa; CREATION (ADAPTATION VAX) CSGI_H 16-02-89 : FS ; Optimisation en C en utilisant memset C C> C*********************************************************************** */ //======================================================================= //function : AdvApp2Var_SysBase::miraz_ //purpose : //======================================================================= void AdvApp2Var_SysBase::miraz_(integer *taille, char *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; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Effectue le transfert d'Integer d'une zone dans une autre */ /* MOTS CLES : */ /* ----------- */ /* TRANSFERT , ENTIER , MEMOIRE */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* NBINTG : Nombre d'entiers */ /* IVECIN : vecteur d'entree */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* IVECOU : vecteur de sortie */ /* COMMONS UTILISES : */ /* ---------------- */ /* REFERENCES APPELEES : */ /* ----------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 26-07-89 : PCR; Declaration en * pour transfert long. nulle */ /* (trap sinon). */ /* 17-10-88 : HK ; Ecriture version originale. */ /* > */ /* *********************************************************************** */ /* ___ NOCTE : Nombre d'octets a transferer */ /* Parameter adjustments */ --ivecou; --ivecin; /* Function Body */ nocte = *nbintg * sizeof(integer); AdvApp2Var_SysBase::mcrfill_((integer *)&nocte, (char *)&ivecin[1], (char *)&ivecou[1]); return 0 ; } /* msifill_ */ //======================================================================= //function : AdvApp2Var_SysBase::msrfill_ //purpose : //======================================================================= int AdvApp2Var_SysBase::msrfill_(integer *nbreel, doublereal *vecent, doublereal * vecsor) { static integer nocte; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Effectue le transfert de reel d'une zone dans une autre */ /* MOTS CLES : */ /* ----------- */ /* TRANSFERT , REEL , MEMOIRE */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* NBREEL : Nombre de reels */ /* VECENT : vecteur d'entree */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* VECSOR : vecteur de sortie */ /* COMMONS UTILISES : */ /* ---------------- */ /* REFERENCES APPELEES : */ /* ----------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 26-07-89 : PCR; Declaration en * pour transfert long. nulle */ /* (trap sinon). */ /* 06-06-89 : HK ; Nettoyages. */ /* 17-10-88 : HK ; Ecriture version originale */ /* > */ /* *********************************************************************** */ /* ___ NOCTE : Nombre d'octets a transferer */ /* Parameter adjustments */ --vecsor; --vecent; /* Function Body */ nocte = *nbreel << 3; AdvApp2Var_SysBase::mcrfill_((integer *)&nocte, (char *)&vecent[1], (char *)&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 }; /* *********************************************************************** */ /* FONCTION : */ /* ---------- */ /* Ecrit un message sur la console alpha si IBB>0 */ /* MOTS CLES : */ /* ----------- */ /* MESSAGE,DEBUG */ /* ARGUMENTS D'ENTREE : */ /* ------------------ */ /* CTEXTE : Texte a ecrire */ /* ARGUMENTS DE SORTIE : */ /* ------------------- */ /* Neant */ /* COMMONS UTILISES : */ /* ---------------- */ /* REFERENCES APPELEES : */ /* ----------------------- */ /* DESCRIPTION/REMARQUES/LIMITATIONS : */ /* ----------------------------------- */ /* $ HISTORIQUE DES MODIFICATIONS : */ /* -------------------------------- */ /* 21-11-90 : DHU; Mise au propre avant transfert a AC */ /* > */ /* *********************************************************************** */ /* DECLARATIONS */ /* *********************************************************************** */ /* *********************************************************************** */ /* TRAITEMENT */ /* *********************************************************************** */ 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 FONCTION : CALL MVRIRAZ(NBELT,DTAB) C ---------- C Effectue une remise a zero d'un tableau de DOUBLE PRECISION C C MOTS CLES : C ----------- C MVRMIRAZ DOUBLE C C ARGUMENTS D'ENTREE : C ------------------ C NBELT : Nombre d'elements du tableau C DTAB : Tableau a initialiser a zero C C ARGUMENTS DE SORTIE : C -------------------- C DTAB : Tableau remis a zero C C COMMONS UTILISES : C ---------------- C C REFERENCES APPELEES : C ----------------------- C C DEMSCRIPTION/REMARQUES/LIMITATIONS : C ----------------------------------- C C C C$ HISTORIQUE DES MODIFICATIONS : C -------------------------------- C 21-11-95 : JMF ; Creation a partir de miraz C C> C*********************************************************************** */ //======================================================================= //function : AdvApp2Var_SysBase::mvriraz_ //purpose : //======================================================================= void AdvApp2Var_SysBase::mvriraz_(integer *taille, char *adt) { integer offset; offset = *taille * 8 ; /* printf(" adt %d long %d\n",adt,offset); */ memset(adt , '\0' , offset) ; }