1 // Copyright (c) 1999-2014 OPEN CASCADE SAS
3 // This file is part of Open CASCADE Technology software library.
5 // This library is free software; you can redistribute it and/or modify it under
6 // the terms of the GNU Lesser General Public License version 2.1 as published
7 // by the Free Software Foundation, with special exception defined in the file
8 // OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
9 // distribution for complete text of the license and disclaimer of any warranty.
11 // Alternatively, this file may be used under the terms of Open CASCADE
12 // commercial license or contractual agreement.
14 // AdvApp2Var_SysBase.cxx
19 #include <AdvApp2Var_Data_f2c.hxx>
20 #include <AdvApp2Var_SysBase.hxx>
21 #include <AdvApp2Var_Data.hxx>
22 #include <Standard.hxx>
35 int macrclw_(intptr_t *iadfld,
39 int macrerr_(intptr_t *iad,
42 int macrgfl_(intptr_t *iadfld,
47 int macrmsg_(const char *crout,
56 int macrstw_(intptr_t *iadfld,
61 int madbtbk_(integer *indice);
64 int magtlog_(const char *cnmlog,
73 int mamdlng_(char *cmdlng,
83 int maoverf_(integer *nbentr,
87 int matrlog_(const char *cnmlog,
95 int matrsym_(const char *cnmsym,
103 int mcrcomm_(integer *kop,
109 int mcrfree_(integer *ibyte,
114 int mcrgetv_(integer *sz,
119 int mcrlocv_(void* t,
124 integer lec, imp, keyb, mae, jscrn, itblt, ibb;
127 #define mcrfill_ABS(a) (((a)<0)?(-(a)):(a))
130 //=======================================================================
131 //function : AdvApp2Var_SysBase
133 //=======================================================================
134 AdvApp2Var_SysBase::AdvApp2Var_SysBase()
137 memset (&mcrstac_, 0, sizeof (mcrstac_));
140 //=======================================================================
141 //function : ~AdvApp2Var_SysBase
143 //=======================================================================
144 AdvApp2Var_SysBase::~AdvApp2Var_SysBase()
146 assert (mcrgene_.ncore == 0); //otherwise memory leaking
149 //=======================================================================
150 //function : macinit_
152 //=======================================================================
153 int AdvApp2Var_SysBase::macinit_(integer *imode,
158 /* ************************************************************************/
161 /* INITIALIZATION OF READING WRITING UNITS AND 'IBB' */
165 /* MANAGEMENT, CONFIGURATION, UNITS, INITIALIZATION */
167 /* INPUT ARGUMENTS : */
168 /* -------------------- */
169 /* IMODE : MODE of INITIALIZATION :
170 0= DEFAULT, IMP IS 6, IBB 0 and LEC 5 */
171 /* 1= FORCE VALUE OF IMP */
172 /* 2= FORCE VALUE OF IBB */
173 /* 3= FORCE VALUE OF LEC */
175 /* ARGUMENT USED ONLY WHEN IMODE IS 1 OR 2 : */
176 /* IVAL : VALUE OF IMP WHEN IMODE IS 1 */
177 /* VALUE OF IBB WHEN IMODE IS 2 */
178 /* VALUE OF LEC WHEN IMODE IS 3 */
179 /* THERE IS NO CONTROL OF VALIDITY OF VALUE OF IVAL . */
181 /* OUTPUT ARGUMENTS : */
182 /* -------------------- */
187 /* REFERENCES CALLED : */
188 /* ------------------- */
189 /* DESCRIPTION/NOTES/LIMITATIONS : */
190 /* ------------------------------- */
192 /* THIS IS ONLY INITIALIZATION OF THE COMMON BLANK FOR ALL */
193 /* MODULES THAT A PRIORI DO NOT NEED TO KNOW THE COMMONS OF T . */
194 /* WHEN A MODIFICATION OF IBB IS REQUIRED (IMODE=2) AN INFO MESSAGE */
195 /* IS SUBMITTED ON IMP, WITH THE NEW VALUE OF IBB. */
197 /* IBB : MODE DEBUG OF STRIM T : RULES OF USE : */
198 /* 0 RESTRAINED VERSION */
199 /* >0 THE GREATER IS IBB THE MORE COMMENTS THE VERSION HAS. */
200 /* FOR EXAMPLE FOR IBB=1 THE ROUTINES CALLED */
201 /* INFORM ON IMP ('INPUT IN TOTO', */
202 /* AND 'OUTPUT FROM TOTO'), AND THE ROUTINES THAT RETURN */
203 /* NON NULL ERROR CODE INFORM IT AS WELL. */
204 /* (BUT IT IS NOT TRUE FOR ALL ROUTINES OF T) */
206 /* ***********************************************************************
213 } else if (*imode == 1) {
214 mblank__.imp = *ival;
215 } else if (*imode == 2) {
216 mblank__.ibb = *ival;
217 } else if (*imode == 3) {
218 mblank__.lec = *ival;
221 /* ----------------------------------------------------------------------*
227 //=======================================================================
228 //function : macrai4_
230 //=======================================================================
231 int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
239 /* ***********************************************************************
244 /* Require dynamic allocation of type INTEGER */
248 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
250 /* INPUT ARGUMENTS : */
251 /* ----------------- */
252 /* NBELEM : Number of required units */
253 /* MAXELM : Max number of units available in ITABLO */
254 /* ITABLO : Reference Address of the rented zone */
256 /* OUTPUT ARGUMENTS : */
257 /* ------------------- */
258 /* IOFSET : Offset */
259 /* IERCOD : Error code */
261 /* = 1 : Max nb of allocations attained */
262 /* = 2 : Incorrect arguments */
263 /* = 3 : Refused dynamic allocation */
266 /* ------------------ */
268 /* REFERENCES CALLED : */
269 /* --------------------- */
272 /* DESCRIPTION/NOTES/LIMITATIONS : */
273 /* ----------------------------------- */
274 /* (Cf description in the heading of MCRRQST) */
276 /* Table ITABLO should be dimensioned to MAXELM by the caller. */
277 /* If the request is lower or equal to MAXELM, IOFSET becomes = 0. */
278 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
280 /* ***********************************************************************
286 iunit = sizeof(integer);
288 if (*nbelem > *maxelm) {
289 /*AdvApp2Var_SysBase::*/mcrrqst_(&iunit, nbelem, itablo, iofset, iercod);
297 //=======================================================================
298 //function : AdvApp2Var_SysBase::macrar8_
300 //=======================================================================
301 int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
310 /* ***********************************************************************
315 /* Demand of dynamic allocation of type DOUBLE PRECISION */
319 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
321 /* INPUT ARGUMENTS : */
322 /* ------------------ */
323 /* NBELEM : Nb of units required */
324 /* MAXELM : Max Nb of units available in XTABLO */
325 /* XTABLO : Reference address of the rented zone */
327 /* OUTPUT ARGUMENTS : */
328 /* ------------------ */
329 /* IOFSET : Offset */
330 /* IERCOD : Error code */
332 /* = 1 : Max Nb of allocations reached */
333 /* = 2 : Arguments incorrect */
334 /* = 3 : Refuse of dynamic allocation */
337 /* ------------------ */
339 /* REFERENCES CALLED : */
340 /* --------------------- */
343 /* DESCRIPTION/NOTES/LIMITATIONS : */
344 /* ----------------------------------- */
345 /* (Cf description in the heading of MCRRQST) */
347 /* Table XTABLO should be dimensioned to MAXELM by the caller. */
348 /* If the request is less or equal to MAXELM, IOFSET becomes = 0. */
349 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
352 /* ***********************************************************************
357 if (*nbelem > *maxelm) {
358 /*AdvApp2Var_SysBase::*/mcrrqst_(&c__8, nbelem, xtablo, iofset, iercod);
366 //=======================================================================
367 //function : macrbrk_
369 //=======================================================================
375 //=======================================================================
376 //function : macrchk_
378 //=======================================================================
379 int AdvApp2Var_SysBase::macrchk_()
381 /* System generated locals */
384 /* Local variables */
390 /* ***********************************************************************
395 /* CONTROL OF EXCESSES OF ALLOCATED MEMORY ZONE */
399 /* SYSTEM, ALLOCATION, MEMORY, CONTROL, EXCESS */
401 /* INPUT ARGUMENTS : */
402 /* ----------------- */
405 /* OUTPUT ARGUMENTS : */
406 /* ------------------- */
410 /* ------------------ */
413 /* REFERENCES CALLED : */
414 /* --------------------- */
415 /* MACRERR, MAOSTRD */
417 /* DESCRIPTION/NOTES/LIMITATIONS : */
418 /* ----------------------------------- */
421 /* ***********************************************************************
424 /* ***********************************************************************
429 /* TABLE OF MANAGEMENT OF DYNAMIC MEMOTY ALLOCATIONS */
433 /* SYSTEM, MEMORY, ALLOCATION */
435 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
436 /* ----------------------------------- */
440 /* ***********************************************************************
443 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
444 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
445 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
446 /* 2 : UNIT OF ALLOCATION */
447 /* 3 : NB OF ALLOCATED UNITS */
448 /* 4 : REFERENCE ADDRESS OF THE TABLE */
450 /* 6 : STATIC ALLOCATION NUMBER */
451 /* 7 : Required allocation size */
452 /* 8 : address of the beginning of allocation */
453 /* 9 : Size of the USER ZONE */
454 /* 10 : ADDRESS of the START FLAG */
455 /* 11 : ADDRESS of the END FLAG */
456 /* 12 : Rank of creation of the allocation */
458 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
459 /* NCORE : NB OF CURRENT ALLOCS */
460 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
461 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
465 /* ----------------------------------------------------------------------*
469 /* ----------------------------------------------------------------------*
472 /* CALCULATE ADDRESS OF T */
474 /* CONTROL OF FLAGS IN THE TABLE */
475 i__1 = mcrgene_.ncore;
476 for (i__ = 0; i__ < i__1; ++i__) {
478 //p to access startaddr and endaddr
479 intptr_t* p = &mcrgene_.icore[i__].startaddr;
480 for (j = 0; j <= 1; ++j) {
481 intptr_t* pp = p + j;
484 ioff = (*pp - loc) / 8;
486 if (t[ioff] != -134744073.) {
488 /* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS
490 /* AND OF RANK ICORE(12,I) */
493 /* BACK-PARCING IN PHASE OF PRODUCTION */
496 /* REMOVAL OF THE ADDRESS OF FLAG TO AVOID REMAKING ITS CONTROL */
511 //=======================================================================
512 //function : macrclw_
514 //=======================================================================
515 int macrclw_(intptr_t *,//iadfld,
523 //=======================================================================
524 //function : AdvApp2Var_SysBase::macrdi4_
526 //=======================================================================
527 int AdvApp2Var_SysBase::macrdi4_(integer *nbelem,
530 intptr_t *iofset, /* Offset long (pmn) */
535 /* ***********************************************************************
540 /* Destruction of dynamic allocation of type INTEGER */
544 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
546 /* INPUT ARGUMENTS : */
547 /* ------------------ */
548 /* NBELEM : Nb of units required */
549 /* MAXELM : Max Nb of units available in ITABLO */
550 /* ITABLO : Reference Address of the allocated zone */
551 /* IOFSET : Offset */
553 /* OUTPUT ARGUMENTS : */
554 /* --------------------- */
555 /* IERCOD : Error Code */
557 /* = 1 : Pb of de-allocation of a zone allocated in table */
558 /* = 2 : The system refuses the demand of de-allocation */
561 /* ------------------ */
563 /* REFERENCES CALLED : */
564 /* --------------------- */
567 /* DESCRIPTION/NOTES/LIMITATIONS : */
568 /* ----------------------------------- */
569 /* (Cf description in the heading of MCRDELT) */
571 /* ***********************************************************************
575 iunit = sizeof(integer);
578 AdvApp2Var_SysBase::mcrdelt_(&iunit,
589 //=======================================================================
590 //function : AdvApp2Var_SysBase::macrdr8_
592 //=======================================================================
593 int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
602 /* ***********************************************************************
607 /* Destruction of dynamic allocation of type DOUBLE PRECISION
612 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
614 /* INPUT ARGUMENTS : */
615 /* -------------------- */
616 /* NBELEM : Nb of units required */
617 /* MAXELM : Max nb of units available in XTABLO */
618 /* XTABLO : Reference Address of the allocated zone */
619 /* IOFSET : Offset */
621 /* OUTPUT ARGUMENTS : */
622 /* ------------------- */
623 /* IERCOD : Error Code */
625 /* = 1 : Pb of de-allocation of a zone allocated on table */
626 /* = 2 : The system refuses the demand of de-allocation */
631 /* REFERENCES CALLEDS : */
632 /* -------------------- */
635 /* DESCRIPTION/NOTES/LIMITATIONS : */
636 /* ----------------------------------- */
637 /* (Cf description in the heading of MCRDELT) */
640 /* ***********************************************************************
645 AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, xtablo, iofset, iercod);
652 //=======================================================================
653 //function : macrerr_
655 //=======================================================================
656 int macrerr_(intptr_t *,//iad,
661 /* Builtin functions */
662 //integer /*do__fio(),*/;
664 /* Fortran I/O blocks */
665 //cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
667 /* ***********************************************************************
672 /* WRITING OF ADDRESS REMOVED IN ALLOCS . */
678 /* INPUT ARGUMENTS : */
679 /* ------------------ */
680 /* IAD : ADDRESS TO INFORM OF REMOVAL */
681 /* NALLOC : NUMBER OF ALLOCATION */
683 /* OUTPUT ARGUMENTS : */
684 /* --------------------- */
690 /* REFERENCES CALLED : */
691 /* ------------------- */
693 /* DESCRIPTION/NOTES/LIMITATIONS : */
694 /* ----------------------------------- */
696 /* ***********************************************************************
699 do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
700 do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
701 do__fio(&c__1, " sur l'allocation ", 18L);
702 do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
709 //=======================================================================
710 //function : macrgfl_
712 //=======================================================================
713 int macrgfl_(intptr_t *iadfld,
719 /* Initialized data */
721 /* original code used static integer ifois=0 which served as static
722 initialization flag and was only used to call matrsym_() once; now
723 this flag is not used as matrsym_() always returns 0 and has no
735 /* ***********************************************************************
740 /* IMPLEMENTATION OF TWO FLAGS START AND END OF THE ALLOCATED ZONE */
741 /* AND SETTING TO OVERFLOW OF THE USER SPACE IN PHASE OF PRODUCTION. */
745 /* ALLOCATION, CONTROL, EXCESS */
747 /* INPUT ARGUMENTS : */
748 /* ------------------ */
749 /* IADFLD : ADDRESS OF THE START FLAG */
750 /* IADFLF : ADDRESS OF THE END FLAG */
751 /* IPHASE : TYPE OF SOFTWARE VERSION : */
752 /* 0 = OFFICIAL VERSION */
753 /* 1 = PRODUCTION VERSION */
754 /* IZNUTI : SIZE OF THE USER ZONE IN OCTETS */
756 /* OUTPUT ARGUMENTS : */
757 /* ------------------ */
761 /* ------------------ */
763 /* REFERENCES CALLED : */
764 /* ------------------- */
767 /* DESCRIPTION/NOTES/LIMITATIONS : */
768 /* ------------------------------- */
771 /* ***********************************************************************
776 /* ***********************************************************************
781 /* TABLE FOR MANAGEMENT OF DYNAMIC ALLOCATIONS OF MEMORY */
785 /* SYSTEM, MEMORY, ALLOCATION */
787 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
788 /* ----------------------------------- */
792 /* ***********************************************************************
794 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
795 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
796 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
797 /* 2 : UNIT OF ALLOCATION */
798 /* 3 : NB OF ALLOCATED UNITS */
799 /* 4 : REFERENCE ADDRESS OF THE TABLE */
801 /* 6 : STATIC ALLOCATION NUMBER */
802 /* 7 : Required allocation size */
803 /* 8 : address of the beginning of allocation */
804 /* 9 : Size of the USER ZONE */
805 /* 10 : ADDRESS of the START FLAG */
806 /* 11 : ADDRESS of the END FLAG */
807 /* 12 : Rank of creation of the allocation */
809 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
810 /* NCORE : NB OF CURRENT ALLOCS */
811 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
812 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
818 /* ----------------------------------------------------------------------*
823 matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
827 /* CALCULATE THE ADDRESS OF T */
830 /* CALCULATE THE OFFSET */
831 ioff = (*iadfld - iadt) / 8;
833 /* SET TO OVERFLOW OF THE USER ZONE IN CASE OF PRODUCTION VERSION */
834 if (*iphase == 1 && novfl == 0) {
836 maoverf_(&ienr, &t[ioff + 1]);
839 /* UPDATE THE START FLAG */
840 t[ioff] = -134744073.;
842 /* FAKE CALL TO STOP THE DEBUGGER : */
845 /* UPDATE THE START FLAG */
846 ioff = (*iadflf - iadt) / 8;
847 t[ioff] = -134744073.;
849 /* FAKE CALL TO STOP THE DEBUGGER : */
855 //=======================================================================
856 //function : macrmsg_
858 //=======================================================================
859 int macrmsg_(const char *,//crout,
869 /* Local variables */
871 char /*cfm[80],*/ cln[3];
873 /* ***********************************************************************
878 /* MESSAGING OF ROUTINES OF ALLOCATION */
884 /* INPUT ARGUMENTSEE : */
885 /* ------------------- */
886 /* CROUT : NAME OF THE CALLING ROUTINE : MCRRQST, MCRDELT, MCRLIST
888 /* ,CRINCR OR CRPROT */
889 /* NUM : MESSAGE NUMBER */
890 /* IT : TABLE OF INTEGER DATA */
891 /* XT : TABLE OF REAL DATA */
892 /* CT : ------------------ CHARACTER */
894 /* OUTPUT ARGUMENTS : */
895 /* --------------------- */
899 /* ------------------ */
901 /* REFERENCES CALLED : */
902 /* --------------------- */
904 /* DESCRIPTION/NOTES/LIMITATIONS : */
905 /* ----------------------------------- */
907 /* ROUTINE FOR TEMPORARY USE, WAITING FOR THE 'NEW' MESSAGE */
908 /* (STRIM 3.3 ?), TO MAKE THE ROUTINES OF ALLOC USABLE */
911 /* DEPENDING ON THE LANGUAGE, WRITING OF THE REQUIRED MESSAGE ON */
913 /* (REUSE OF SPECIFS OF VFORMA) */
915 /* THE MESSAGE IS INITIALIZED AT 'MESSAGE MISSING', AND IT IS */
916 /* REPLACED BY THE REQUIRED MESSAGE IF EXISTS. */
918 /* ***********************************************************************
923 /* ----------------------------------------------------------------------*
925 /* FIND MESSAGE DEPENDING ON THE LANGUAGE , THE ROUTINE */
926 /* AND THE MESSAGE NUMBER */
928 /* READING OF THE LANGUAGE : */
929 /* Parameter adjustments */
937 /* INUM : TYPE OF MESSAGE : 0 AS TEXT, 1 1 INTEGER TO BE WRITTEN */
938 /* -1 MESSAGE INEXISTING (1 INTEGER AND 1 CHAIN) */
942 if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
943 __s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
944 e de nom : ',A8)", 80L, 71L);
945 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
948 __s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
949 ee(s) : ',I6,/)", 80L, 62L);
950 } else if (*num == 2) {
952 __s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
953 } else if (*num == 3) {
955 __s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
957 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
960 __s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
961 e pas ')", 80L, 56L);
962 } else if (*num == 2) {
964 __s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
965 ion de memoire ')", 80L, 65L);
967 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
970 __s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
971 atteint :',I6)", 80L, 62L);
972 } else if (*num == 2) {
974 __s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
976 } else if (*num == 3) {
978 __s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
979 de ',I12,' octets')", 80L, 66L);
981 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
984 __s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
985 iste pas')", 80L, 57L);
987 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
990 __s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
991 ) : ',I12)", 80L, 57L);
995 } else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
996 __s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
997 mm des Namens : ',A8)", 80L, 76L);
998 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1001 __s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
1002 sung(en) : ',I6,/)", 80L, 65L);
1003 } else if (*num == 2) {
1005 __s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
1006 } else if (*num == 3) {
1008 __s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
1011 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1014 __s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
1015 nicht !! ')", 80L, 59L);
1016 } else if (*num == 2) {
1018 __s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
1019 Zuweisung !!')", 80L, 61L);
1021 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1024 __s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
1025 icht :',I6)", 80L, 58L);
1026 } else if (*num == 2) {
1028 __s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
1030 } else if (*num == 3) {
1032 __s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
1033 ,I12,' Bytes')", 80L, 61L);
1035 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1038 __s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
1039 stiert nicht !! ')", 80L, 65L);
1041 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1044 __s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
1045 : ',I12)", 80L, 55L);
1050 __s__copy(cfm, "(' Message number ',I5,' is missing ' \
1051 ,'for program named: ',A8)", 80L, 93L);
1052 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1055 __s__copy(cfm, "(/,' number of memory allocations carried out: \
1056 ',I6,/)", 80L, 54L);
1057 } else if (*num == 2) {
1059 __s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
1060 } else if (*num == 3) {
1062 __s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
1064 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1067 __s__copy(cfm, "(' Memory allocation to delete does not exist !\
1069 } else if (*num == 2) {
1071 __s__copy(cfm, "(' System refuses deletion of memory allocation\
1074 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1077 __s__copy(cfm, "(' max number of memory allocations reached :',\
1079 } else if (*num == 2) {
1081 __s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
1083 } else if (*num == 3) {
1085 __s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
1086 ' bytes ')", 80L, 57L);
1088 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1091 __s__copy(cfm, "(' Memory allocation to increment does not exis\
1092 t !! ')", 80L, 54L);
1094 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1097 __s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
1103 /* ----------------------------------------------------------------------*
1105 /* iMPLEMENTATION OF WRITE , WITH OR WITHOUT DATA : */
1108 } else if (inum == 1) {
1110 do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
1113 /* MESSAGE DOES NOT EXIST ... */
1115 do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
1116 do__fio(&c__1, crout, crout_len);
1122 //=======================================================================
1123 //function : macrstw_
1125 //=======================================================================
1126 int macrstw_(intptr_t *,//iadfld,
1127 intptr_t *,//iadflf,
1134 //=======================================================================
1135 //function : madbtbk_
1137 //=======================================================================
1138 int madbtbk_(integer *indice)
1144 //=======================================================================
1145 //function : AdvApp2Var_SysBase::maermsg_
1147 //=======================================================================
1148 int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
1150 ftnlen )//cnompg_len)
1156 //=======================================================================
1157 //function : magtlog_
1159 //=======================================================================
1160 int magtlog_(const char *cnmlog,
1161 const char *,//chaine,
1165 ftnlen )//chaine_len)
1169 /* Local variables */
1174 /* **********************************************************************
1179 /* RETURN TRANSLATION OF "NAME LOGIC STRIM" IN */
1180 /* "INTERNAL SYNTAX" CORRESPONDING TO "PLACE OF RANKING" */
1184 /* NOM LOGIQUE STRIM , TRADUCTION */
1186 /* INPUT ARGUMENTS : */
1187 /* ------------------ */
1188 /* CNMLOG : NAME OF "NAME LOGIC STRIM" TO TRANSLATE */
1190 /* OUTPUT ARGUMENTS : */
1191 /* ------------------- */
1192 /* CHAINE : ADDRESS OF "PLACE OF RANKING" */
1193 /* LONG : USEFUL LENGTH OF "PLACE OF RANKING" */
1194 /* IERCOD : ERROR CODE */
1195 /* IERCOD = 0 : OK */
1196 /* IERCOD = 5 : PLACE OF RANKING CORRESPONDING TO INEXISTING LOGIC NAME */
1198 /* IERCOD = 6 : TRANSLATION TOO LONG FOR THE 'CHAIN' VARIABLE */
1199 /* IERCOD = 7 : CRITICAL ERROR */
1201 /* COMMONS USED : */
1202 /* ---------------- */
1205 /* REFERENCES CALLED : */
1206 /* --------------------- */
1207 /* GNMLOG, MACHDIM */
1209 /* DESCRIPTION/NOTES/LIMITATIONS : */
1210 /* ------------------------------- */
1212 /* SPECIFIC SGI ROUTINE */
1214 /* IN ALL CASES WHEN IERCOD IS >0, NO RESULT IS RETURNED*/
1215 /* NOTION OF "USER SYNTAX' AND "INTERNAL SYNTAX" */
1216 /* --------------------------------------------------- */
1218 /* THE "USER SYNTAX" IS THE SYNTAX WHERE THE USER*/
1219 /* VISUALIZES OR INDICATES THE FILE OR DIRECTORY NAME */
1220 /* DURING A SESSION OF STRIM100 */
1222 /* "INTERNAL SYNTAX" IS SYNTAX USED TO CARRY OUT */
1223 /* OPERATIONS OF FILE PROCESSING INSIDE THE CODE */
1224 /* (OPEN,INQUIRE,...ETC) */
1227 /* ***********************************************************************
1230 /* ***********************************************************************
1234 /* ***********************************************************************
1237 /* ***********************************************************************
1243 /* CONTROL OF EXISTENCE OF THE LOGIC NAME */
1245 matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
1253 /* CONTROL OF THE LENGTH OF CHAIN */
1255 if (ibid > __i__len()/*chaine, chaine_len)*/) {
1259 //__s__copy(chaine, cbid, chaine_len, ibid);
1264 /* ***********************************************************************
1266 /* ERROR PROCESSING */
1267 /* ***********************************************************************
1272 //__s__copy(chaine, " ", chaine_len, 1L);
1277 //__s__copy(chaine, " ", chaine_len, 1L);
1282 //__s__copy(chaine, " ", chaine_len, 1L);
1284 /* ***********************************************************************
1286 /* RETURN TO THE CALLING PROGRAM */
1287 /* ***********************************************************************
1294 //=======================================================================
1295 //function : mainial_
1297 //=======================================================================
1298 int AdvApp2Var_SysBase::mainial_()
1305 //=======================================================================
1306 //function : AdvApp2Var_SysBase::maitbr8_
1308 //=======================================================================
1309 int AdvApp2Var_SysBase::maitbr8_(integer *itaill,
1314 integer c__504 = 504;
1316 /* Initialized data */
1318 doublereal buff0[63] = {
1319 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1320 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1321 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1325 /* System generated locals */
1328 /* Local variables */
1330 doublereal buffx[63];
1331 integer nbfois, noffst, nreste, nufois;
1333 /* ***********************************************************************
1338 /* INITIALIZATION TO A GIVEN VALUE OF A TABLE OF REAL *8 */
1342 /* MANIPULATIONS, MEMORY, INITIALIZATION, DOUBLE-PRECISION */
1344 /* INPUT ARGUMENTS : */
1345 /* ----------------- */
1346 /* ITAILL : SIZE OF THE TABLE */
1347 /* XTAB : TABLE TO INITIALIZE WITH XVAL */
1348 /* XVAL : VALUE TO SET IN XTAB(FROM 1 TO ITAILL) */
1350 /* OUTPUT ARGUMENTS : */
1351 /* ------------------ */
1352 /* XTAB : INITIALIZED TABLE */
1354 /* COMMONS USED : */
1355 /* -------------- */
1357 /* REFERENCES CALLED : */
1358 /* ------------------- */
1360 /* DESCRIPTION/NOTES/LIMITATIONS : */
1361 /* ----------------------------------- */
1363 /* ONE CALLS MCRFILL WHICH MOVES BY PACKS OF 63 REALS */
1365 /* THE INITIAL PACK IS BUFF0 INITIATED BY DATA IF THE VALUE IS 0 */
1366 /* OR OTHERWISE BUFFX INITIATED BY XVAL (LOOP). */
1369 /* PORTABILITY : YES */
1374 /* ***********************************************************************
1378 /* Parameter adjustments */
1383 /* ----------------------------------------------------------------------*
1386 nbfois = *itaill / 63;
1387 noffst = nbfois * 63;
1388 nreste = *itaill - noffst;
1393 for (nufois = 1; nufois <= i__1; ++nufois) {
1394 AdvApp2Var_SysBase::mcrfill_(&c__504, buff0, &xtab[(nufois - 1) * 63 + 1]);
1401 AdvApp2Var_SysBase::mcrfill_(&i__1, buff0, &xtab[noffst + 1]);
1404 for (i__ = 1; i__ <= 63; ++i__) {
1405 buffx[i__ - 1] = *xval;
1410 for (nufois = 1; nufois <= i__1; ++nufois) {
1411 AdvApp2Var_SysBase::mcrfill_(&c__504, buffx, &xtab[(nufois - 1) * 63 + 1]);
1418 AdvApp2Var_SysBase::mcrfill_(&i__1, buffx, &xtab[noffst + 1]);
1422 /* ----------------------------------------------------------------------*
1428 //=======================================================================
1429 //function : mamdlng_
1431 //=======================================================================
1432 int mamdlng_(char *,//cmdlng,
1433 ftnlen )//cmdlng_len)
1438 /* ***********************************************************************
1443 /* RETURN THE CURRENT LANGUAGE */
1447 /* MANAGEMENT, CONFIGURATION, LANGUAGE, READING */
1449 /* INPUT ARGUMENTS : */
1450 /* -------------------- */
1451 /* CMDLNG : LANGUAGE */
1453 /* OUTPUT ARGUMENTS : */
1454 /* ------------------- */
1457 /* COMMONS USED : */
1458 /* ------------------ */
1461 /* REFERENCES CALLED : */
1462 /* --------------------- */
1465 /* DESCRIPTION/NOTES/LIMITATIONS : */
1466 /* ----------------------------------- */
1467 /* RIGHT OF USAGE : ANY APPLICATION */
1469 /* ATTENTION : THIS ROUTINE DEPENDS ON PRELIMINARY INITIALISATION */
1470 /* ---------- WITH AMDGEN. */
1471 /* SO IT IS ENOUGH TO PROVIDE THAT THIS INIT IS */
1472 /* CORRECTLY IMPLEMENTED IN THE RESPECTIVE PROGRAMS */
1474 /* ***********************************************************************
1478 /* INCLUDE MACETAT */
1481 /* ***********************************************************************
1486 /* CONTAINS INFORMATION ABOUT THE COMPOSITION OF */
1487 /* THE EXECUTABLE AND ITS ENVIRONMENT : */
1489 /* - PRESENT APPLICATIONS */
1490 /* - AUTHORIZED TYPES OF ENTITIES (NON USED) */
1491 /* AND INFORMATION DESCRIBING THE CURRENT STATE : */
1492 /* - CURRENT APPLICATION */
1493 /* - MODE OF USAGE (NOT USED) */
1497 /* APPLICATION, LANGUAGE */
1499 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
1500 /* ----------------------------------- */
1502 /* A) CHLANG*4 : LIST OF POSSIBLE VALUES OF THE LANGUAGE : */
1503 /* 'FRA ','DEU ','ENG ' */
1505 /* CHL10N*4 : LIST OF POSSIBLE VALUES OF THE LOCALIZATION : */
1506 /* 'FRA ','DEU ','ENG ', 'JIS ' */
1508 /* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : CURRENT, PREVIOUS AND NEXT APPLICATION */
1510 /* C) CHMODE*4 : CURRENT MODE (NOT USED) */
1512 /* D) CHPRES*2 (1:NBRMOD) : LIST OF APPLICATIONS TAKEN INTO ACCOUNT */
1514 /* Rang ! Code interne ! Application */
1515 /* ---------------------------------------------------------- */
1516 /* 1 ! CD ! Modeling 2D */
1517 /* 2 ! CA ! Modeling 2D by learning */
1518 /* 3 ! CP ! Parameterized 2D modelization */
1519 /* 4 ! PC ! Rheological 2D modelization */
1520 /* 5 ! CU ! Milling 2 Axes 1/2 */
1521 /* 6 ! CT ! Turning */
1522 /* 7 ! TS ! 3D surface modeling */
1523 /* 8 ! TV ! 3D volume modeling */
1524 /* 9 ! MC ! Surface Meshing */
1525 /* 10 ! MV ! Volume Meshing */
1526 /* 11 ! TU ! Machining by 3 axes */
1527 /* 12 ! T5 ! Machining by 3-5 axes */
1528 /* 13 ! TR ! Machinning by 5 axes of regular surfaces */
1529 /* 14 ! IG ! Interface IGES */
1530 /* 15 ! ST ! Interface SET */
1531 /* 16 ! VD ! Interface VDA */
1532 /* 17 ! IM ! Interface of modeling */
1533 /* 18 ! GA ! Generator APT/IFAPT */
1534 /* 19 ! GC ! Generator COMPACT II */
1535 /* 20 ! GP ! Generator PROMO */
1536 /* 21 ! TN ! Machining by numerical copying */
1537 /* 22 ! GM ! Management of models */
1538 /* 23 ! GT ! Management of trace */
1539 /* ---------------------------------------------------------- */
1544 /* ***********************************************************************
1547 /* NUMBER OF APPLICATIONS TAKEN INTO ACCOUNT */
1550 /* NUMBER OF ENTITY TYPES MANAGED BY STRIM 100 */
1551 //__s__copy(cmdlng, macetat_.chlang, cmdlng_len, 4L);
1556 //=======================================================================
1557 //function : maostrb_
1559 //=======================================================================
1565 //=======================================================================
1566 //function : maostrd_
1568 //=======================================================================
1573 /* ***********************************************************************
1578 /* REFINE TRACE-BACK IN PRODUCTION PHASE */
1582 /* FUNCTION, SYSTEM, TRACE-BACK, REFINING, DEBUG */
1584 /* INPUT ARGUMENTS : */
1585 /* ----------------- */
1588 /* OUTPUT ARGUMENTS E : */
1589 /* -------------------- */
1592 /* COMMONS USED : */
1593 /* -------------- */
1596 /* REFERENCES CALLED : */
1597 /* ------------------- */
1600 /* DESCRIPTION/NOTES/LIMITATIONS : */
1601 /* ----------------------------------- */
1602 /* THIS ROUTINE SHOULD BE CALLED TO REFINE */
1603 /* TRACE-BACK IN PRODUCTION PHASE AND LEAVE TO TESTERS THE */
1604 /* POSSIBILITY TO GET TRACE-BACK IN */
1605 /* CLIENT VERSIONS IF ONE OF THE FOLLOWING CONDITIONS IS */
1607 /* - EXISTENCE OF SYMBOL 'STRMTRBK' */
1608 /* - EXISTENCE OF FILE 'STRMINIT:STRMTRBK.DAT' */
1612 /* ***********************************************************************
1621 //=======================================================================
1622 //function : maoverf_
1624 //=======================================================================
1625 int maoverf_(integer *nbentr,
1629 /* Initialized data */
1633 /* System generated locals */
1636 /* Local variables */
1638 doublereal buff[63];
1639 integer ioct, indic, nrest, icompt;
1641 /* ***********************************************************************
1646 /* Initialisation in overflow of a tableau with DOUBLE PRECISION */
1650 /* MANIPULATION, MEMORY, INITIALISATION, OVERFLOW */
1652 /* INPUT ARGUMENTS : */
1653 /* ----------------- */
1654 /* NBENTR : Number of entries in the table */
1656 /* OUTPUT ARGUMENTS : */
1657 /* ------------------ */
1658 /* DATBLE : Table double precision initialized in overflow */
1660 /* COMMONS USED : */
1661 /* ------------------ */
1662 /* R8OVR contained in the include MAOVPAR.INC */
1664 /* REFERENCES CALLED : */
1665 /* --------------------- */
1668 /* DESCRIPTION/NOTES/LIMITATIONS : */
1669 /* ----------------------------------- */
1670 /* 1) Doc. programmer : */
1672 /* This routine initialized to positive overflow a table with */
1673 /* DOUBLE PRECISION. */
1675 /* Other types of tables (INTEGER*2, INTEGER, REAL, ...) */
1676 /* are not managed by the routine. */
1678 /* It is usable in phase of development to detect the */
1679 /* errors of initialization. */
1681 /* In official version, these calls will be inactive. */
1683 /* ACCESs : Agreed with AC. */
1685 /* The routine does not return error code. */
1687 /* Argument NBELEM should be positive. */
1688 /* If it is negative or null, display message "MAOVERF : NBELEM = */
1689 /* valeur_de_NBELEM" and a Trace Back by the call of routine MAOSTRB. */
1692 /* 2) Doc. designer : */
1694 /* The idea is to minimize the number of calls */
1695 /* to the routine of transfer of numeric zones, */
1696 /* ---------- for the reason of performance. */
1697 /* ! buffer ! For this a table of NLONGR */
1698 /* !__________! DOUBLE PRECISIONs is reserved. This buffer is initialized by */
1699 /* <----------> the instruction DATA. The overflow is accessed in a */
1700 /* NLONGR*8 specific COMMON not by a routine as */
1701 /* the initialisation is done by DATA. */
1703 /* * If NBENTR<NLONGR, a part of the buffer is transferred*/
1704 /* DTABLE in DTABLE. */
1706 /* ! amorce ! * Otherwise, the entire buffer is transferred in DTABLE. */
1707 /* !__________! This initiates it. Then a loop is execute, which at each
1709 /* ! temps 1 ! iteration transfers the part of the already initialized table */
1710 /* !__________! in the one that was not yet initialized. */
1711 /* ! ! The size of the zone transferred by each call to MCRFILL
1713 /* ! temps 2 ! is NLONGR*2**(numero_de_l'iteration). When
1715 /* ! ! the size of the table to be initialized is */
1716 /* !__________! less than the already initialized size, the loop is */
1717 /* ! ! abandoned and thev last transfer is carried out to */
1718 /* ! ! initialize the remaining table, except for the case when the size */
1719 /* ! ! of the table is of type NLONGR*2**K. */
1721 /* ! ! * NLONGR will be equal to 19200. */
1730 /* ***********************************************************************
1733 /* Inclusion of MAOVPAR.INC */
1736 /* INCLUDE MAOVPAR */
1737 /* ***********************************************************************
1742 /* DEFINES SPECIFIC LIMITED VALUES. */
1746 /* SYSTEM, LIMITS, VALUES, SPECIFIC */
1748 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
1749 /* ----------------------------------- */
1750 /* *** THEY CAN'T BE REMOVED DURING EXECUTION. */
1752 /* *** THE VALUES OF UNDERFLOW AND OVERFLOW CAN'T BE */
1753 /* DEFINED IN DECIMAL VALUES (ERROR OF COMPILATION D_FLOAT) */
1754 /* THEY ARE DEFINED AS HEXADECIMAL VALUES */
1758 /* ***********************************************************************
1762 /* DECLARATION OF THE COMMON FOR NUMERIC TYPES */
1765 /* DECLARATION OF THE COMMON FOR CHARACTER TYPES*/
1769 /* LOCAL VARIABLES */
1774 /* Parameter adjustments */
1779 /* vJMB R8OVR IS NOT YET initialized, so impossible to use DATA
1781 /* DATA BUFF / NLONGR * R8OVR / */
1783 /* init of BUFF is done only once */
1786 for (icompt = 1; icompt <= 63; ++icompt) {
1787 buff[icompt - 1] = maovpar_.r8ovr;
1796 nrest = *nbentr << 3;
1797 AdvApp2Var_SysBase::mcrfill_(&nrest, buff, &dtable[1]);
1800 /* Start & initialization */
1802 AdvApp2Var_SysBase::mcrfill_(&ioct, buff, &dtable[1]);
1805 /* Loop. The upper limit is the integer value of the logarithm of base 2
1807 /* of NBENTR/NLONGR. */
1808 i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.))
1810 for (ibid = 1; ibid <= i__1; ++ibid) {
1812 AdvApp2Var_SysBase::mcrfill_(&ioct, &dtable[1], &dtable[indic + 1]);
1819 nrest = ( *nbentr - indic ) << 3;
1822 AdvApp2Var_SysBase::mcrfill_(&nrest, &dtable[1], &dtable[indic + 1]);
1829 //=======================================================================
1830 //function : AdvApp2Var_SysBase::maovsr8_
1832 //=======================================================================
1833 int AdvApp2Var_SysBase::maovsr8_(integer *ivalcs)
1835 *ivalcs = maovpar_.r8ncs;
1839 //=======================================================================
1840 //function : matrlog_
1842 //=======================================================================
1843 int matrlog_(const char *,//cnmlog,
1844 const char *,//chaine,
1847 ftnlen ,//cnmlog_len,
1848 ftnlen )//chaine_len)
1857 //=======================================================================
1858 //function : matrsym_
1860 //=======================================================================
1861 int matrsym_(const char *cnmsym,
1862 const char *,//chaine,
1866 ftnlen )//chaine_len)
1869 /* Local variables */
1870 char chainx[255] = {};
1872 /* ***********************************************************************
1877 /* RETURN THE VALUE OF A SYMBOL DEFINED DURING THE */
1878 /* INITIALISATION OF A USER */
1882 /* TRANSLATION, SYMBOL */
1884 /* INPUT ARGUMENTS : */
1885 /* -------------------- */
1886 /* CNMSYM : NAME OF THE SYMBOL */
1888 /* OUTPUT ARGUMENTS : */
1889 /* ------------------ */
1890 /* CHAINE : TRANSLATION OF THE SYMBOL */
1891 /* LENGTH : USEFUL LENGTH OF THE CHAIN */
1892 /* IERCOD : ERROR CODE */
1894 /* = 1 : INEXISTING SYMBOL */
1895 /* = 2 : OTHER ERROR */
1897 /* COMMONS USED : */
1898 /* ------------------ */
1901 /* REFERENCES CALLED : */
1902 /* --------------------- */
1903 /* LIB$GET_SYMBOL,MACHDIM */
1905 /* DESCRIPTION/NOTES/LIMITATIONS : */
1906 /* ----------------------------------- */
1907 /* - THIS ROUTINE IS VAX SPECIFIC */
1908 /* - IN CASE OF ERROR (IERCOD>0), CHAIN = ' ' AND LENGTH = 0 */
1909 /* - IF THE INPUT VARIABLE CNMSYM IS EMPTY, THE ROUTINE RETURNS IERCOD=1*/
1911 /* ***********************************************************************
1917 /* SGI CALL MAGTLOG (CNMSYM,CHAINE,LENGTH,IERCOD) */
1918 magtlog_(cnmsym, chainx, length, iercod, cnmsym_len, 255L);
1927 //if (__s__cmp(chainx, "NONE", 255L, 4L) == 0) {
1928 if (__s__cmp() == 0) {
1929 //__s__copy(chainx, " ", 255L, 1L);
1932 //__s__copy(chaine, chainx, chaine_len, 255L);
1936 /* ***********************************************************************
1938 /* ERROR PROCESSING */
1939 /* ***********************************************************************
1947 //=======================================================================
1948 //function : mcrcomm_
1950 //=======================================================================
1951 int mcrcomm_(integer *kop,
1957 /* Initialized data */
1961 /* System generated locals */
1964 /* Local variables */
1966 doublereal dtab[32000];
1967 intptr_t itab[160] /* was [4][40] */;
1972 /************************************************************************
1977 /* DYNAMIC ALLOCATION ON COMMON */
1981 /* . ALLOCDYNAMIQUE, MEMORY, COMMON, ALLOC */
1983 /* INPUT ARGUMENTS : */
1984 /* ------------------ */
1985 /* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */
1986 /* NOCT : NUMBER OF OCTETS */
1988 /* OUTPUT ARGUMENTS : */
1989 /* ------------------- */
1990 /* IADR : ADDRESS IN MEMORY OF THE FIRST OCTET */
1993 /* IERCOD : ERROR CODE */
1995 /* IERCOD = 0 : OK */
1996 /* IERCOD > 0 : CRITICAL ERROR */
1997 /* IERCOD < 0 : WARNING */
1998 /* IERCOD = 1 : ERROR DESCRIPTION */
1999 /* IERCOD = 2 : ERROR DESCRIPTION */
2001 /* COMMONS USED : */
2002 /* ---------------- */
2006 /* REFERENCES CALLED : */
2007 /* ---------------------- */
2012 /* DESCRIPTION/NOTES/LIMITATIONS : */
2013 /* ----------------------------------- */
2015 /* ATTENTION .... ITAB ARE NTAB NOT SAVED BETWEEN 2 CALLS..
2019 /* ***********************************************************************
2022 /* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */
2024 /* ITAB : TABLE OF MANAGEMENT OF DTAB, ALLOCATED MEMORY ZONE . */
2025 /* NTAB : NUMBER OF COMPLETED ALLOCATIONS. */
2026 /* FORMAT OF ITAB : NUMBER OF ALLOCATED REAL*8, ADDRESS OF THE 1ST REAL*8
2028 /* , NOCT , VIRTUAL ADDRESS */
2030 /* PP COMMON / CRGEN2 / DTAB */
2033 /* ----------------------------------------------------------------------*
2038 /* ALLOCATION : FIND A HOLE */
2052 for (i__ = 1; i__ <= i__1; ++i__) {
2056 ipre = itab[((i__ - 1) << 2) - 3] + itab[((i__ - 1) << 2) - 4];
2059 ideb = itab[(i__ << 2) - 3];
2063 if ((ideb - ipre) << 3 >= *noct) {
2064 /* A HOLE WAS FOUND */
2066 for (j = ntab; j >= i__2; --j) {
2067 for (k = 1; k <= 4; ++k) {
2068 itab[k + ((j + 1) << 2) - 5] = itab[k + (j << 2) - 5];
2074 itab[(i__ << 2) - 4] = *noct / 8 + 1;
2075 itab[(i__ << 2) - 3] = ipre;
2076 itab[(i__ << 2) - 2] = *noct;
2077 mcrlocv_(&dtab[ipre - 1], iadr);
2078 itab[(i__ << 2) - 1] = *iadr;
2089 /* ----------------------------------- */
2090 /* DESTRUCTION OF THE ALLOCATION NUM : */
2094 for (i__ = 1; i__ <= i__1; ++i__) {
2095 if (*noct != itab[(i__ << 2) - 2]) {
2098 if (*iadr != itab[(i__ << 2) - 1]) {
2101 /* THE ALLOCATION TO BE REMOVED WAS FOUND */
2103 for (j = i__ + 1; j <= i__2; ++j) {
2104 for (k = 1; k <= 4; ++k) {
2105 itab[k + ((j - 1) << 2) - 5] = itab[k + (j << 2) - 5];
2116 /* THE ALLOCATION DOES NOT EXIST */
2126 //=======================================================================
2127 //function : AdvApp2Var_SysBase::mcrdelt_
2129 //=======================================================================
2130 int AdvApp2Var_SysBase::mcrdelt_(integer *iunit,
2139 integer noct, iver, ksys, i__, n, nrang,
2141 intptr_t iadfd, iadff, iaddr, loc; /* Les adrresses en long*/
2144 /* ***********************************************************************
2149 /* DESTRUCTION OF A DYNAMIC ALLOCATION */
2153 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
2155 /* INPUT ARGUMENTS : */
2156 /* ------------------ */
2157 /* IUNIT : NUMBER OF OCTETS OF THE ALLOCATION UNIT */
2158 /* ISIZE : NUMBER OF UNITS REQUIRED */
2159 /* T : REFERENCE ADDRESS */
2160 /* IOFSET : OFFSET */
2162 /* OUTPUT ARGUMENTS : */
2163 /* ------------------- */
2164 /* IERCOD : ERROR CODE */
2166 /* = 1 : PB OF DE-ALLOCATION OF A ZONE ALLOCATED IN COMMON */
2167 /* = 2 : THE SYSTEM REFUSES TO DEMAND DE-ALLOCATION */
2168 /* = 3 : THE ALLOCATION TO BE DESTROYED DOES NOT EXIST. */
2170 /* COMMONS USED : */
2171 /* ---------------- */
2174 /* REFERENCES CALLED : */
2175 /* --------------------- */
2178 /* DESCRIPTION/NOTES/LIMITATIONS : */
2179 /* ----------------------------------- */
2181 /* 1) UTILISATEUR */
2184 /* MCRDELT FREES ALLOCATED MEMORY ZONE */
2185 /* BY ROUTINE MCRRQST (OR CRINCR) */
2187 /* THE MEANING OF ARGUMENTS IS THE SAME AS MCRRQST */
2189 /* *** ATTENTION : */
2191 /* IERCOD=2 : CASE WHEN THE SYSTEM CANNOT FREE THE ALLOCATED MEMORY, */
2192 /* THE FOLLOWING MESSAGE APPEARS SYSTEMATICALLY ON CONSOLE ALPHA : */
2193 /* "THe system refuseS destruction of memory allocation" */
2195 /* IERCOD=3 CORRESPONDS TO THE CASE WHEN THE ARGUMENTS ARE NOT CORRECT */
2196 /* (THEY DO NOT ALLOW TO RECOGNIZE THE ALLOCATION IN THE TABLE)
2199 /* When the allocation is destroyed, the corresponding IOFSET is set to */
2200 /* 2 147 483 647. So, if one gets access to the table via IOFSET, there is */
2201 /* a trap. This allows to check that the freed memory zone is not usede. This verification is */
2202 /* valid only if the same sub-program uses and destroys the allocation. */
2205 /* ***********************************************************************
2208 /* COMMON OF PARAMETERS */
2210 /* COMMON OF STATISTICS */
2211 /* INCLUDE MCRGENE */
2213 /* ***********************************************************************
2218 /* TABLE OF MANAGEMENT OF DYNAMIC ALLOCATIONS IN MEMORY */
2222 /* SYSTEM, MEMORY, ALLOCATION */
2224 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2225 /* ----------------------------------- */
2229 /* ***********************************************************************
2231 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2232 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2233 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2234 /* 2 : UNIT OF ALLOCATION */
2235 /* 3 : NB OF ALLOCATED UNITS */
2236 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2238 /* 6 : STATIC ALLOCATION NUMBER */
2239 /* 7 : Required allocation size */
2240 /* 8 : address of the beginning of allocation */
2241 /* 9 : Size of the USER ZONE */
2242 /* 10 : ADDRESS of the START FLAG */
2243 /* 11 : ADDRESS of the END FLAG */
2244 /* 12 : Rank of creation of the allocation */
2246 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2247 /* NCORE : NB OF CURRENT ALLOCS */
2248 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2249 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2253 /* ----------------------------------------------------------------------*
2257 /* 20-10-86 : BF ; INITIAL VERSION */
2260 /* NRQST : NUMBER OF ALLOCATIONS */
2261 /* NDELT : NUMBER OF LIBERATIONS */
2262 /* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2263 /* MBYTE : MAX NUMBER OF OCTETS */
2268 /* SEARCH IN MCRGENE */
2273 for (i__ = mcrgene_.ncore - 1; i__ >= 0; --i__) {
2274 if (*iunit == mcrgene_.icore[i__].unit && *isize ==
2275 mcrgene_.icore[i__].reqsize && loc == mcrgene_.icore[i__].loc
2276 && *iofset == mcrgene_.icore[i__].offset) {
2284 /* IF THE ALLOCATION DOES NOT EXIST, LEAVE */
2290 /* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */
2292 ksys = mcrgene_.icore[n].alloctype;
2293 ibyte = mcrgene_.icore[n].size;
2294 iaddr = mcrgene_.icore[n].addr;
2295 iadfd = mcrgene_.icore[n].startaddr;
2296 iadff = mcrgene_.icore[n].endaddr;
2297 nrang = mcrgene_.icore[n].rank;
2299 /* Control of flags */
2306 if (ksys == static_allocation) {
2307 /* DE-ALLOCATION ON COMMON */
2309 mcrcomm_(&kop, &ibyte, &iaddr, &ier);
2314 /* DE-ALLOCATION SYSTEM */
2315 mcrfree_(&ibyte, iaddr, &ier);
2321 /* CALL ALLOWING TO CANCEL AUTOMATIC WATCH BY THE DEBUGGER */
2323 macrclw_(&iadfd, &iadff, &nrang);
2325 /* UPDATE OF STATISTICS */
2326 ++mcrstac_.ndelt[ksys];
2327 mcrstac_.nbyte[ksys] -= mcrgene_.icore[n].unit *
2328 mcrgene_.icore[n].reqsize;
2330 /* REMOVAL OF PARAMETERS IN MCRGENE */
2331 if (n < MAX_ALLOC_NB - 1) {
2332 noct = (mcrgene_.ncore - (n + 1)) * sizeof(mcrgene_.icore[0]);
2333 AdvApp2Var_SysBase::mcrfill_(&noct,
2334 &mcrgene_.icore[n + 1],
2335 &mcrgene_.icore[n]);
2339 /* *** Set to overflow of IOFSET */
2341 /* nested scope needed to avoid gcc compilation error crossing
2342 initialization with goto*/
2343 /* assign max positive integer to *iofset */
2344 const size_t shift = sizeof (*iofset) * 8 - 1;
2345 *iofset = (uintptr_t(1) << shift) - 1 /*2147483647 for 32bit*/;
2349 /* ----------------------------------------------------------------------*
2351 /* ERROR PROCESSING */
2354 /* REFUSE DE-ALLOCATION BY ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
2356 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2360 /* REFUSE DE-ALLOCATION BY THE SYSTEM */
2363 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2364 macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
2368 /* ALLOCATION DOES NOT EXIST */
2371 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2383 C*********************************************************************
2387 C Transfer a memory zone in another by managing intersections
2391 C MANIPULATION, MEMORY, TRANSFER, CHARACTER
2395 C nb_car : integer*4 number of characters to transfer.
2396 C source : source memory zone.
2398 C OUTPUT ARGUMENTS :
2399 C -------------------
2400 C dest : zone memory destination.
2405 C REFERENCES CALLED :
2406 C -------------------
2408 C DEMSCRIPTION/NOTES/LIMITATIONS :
2409 C -----------------------------------
2410 C Routine portable UNIX (SGI, ULTRIX, BULL)
2414 C**********************************************************************
2417 //=======================================================================
2418 //function : AdvApp2Var_SysBase::mcrfill_
2420 //=======================================================================
2421 int AdvApp2Var_SysBase::mcrfill_(integer *size,
2426 char *jmin=static_cast<char*> (tin);
2427 char *jmout=static_cast<char*> (tout);
2428 if (mcrfill_ABS(jmout-jmin) >= *size)
2429 memcpy( tout, tin, *size);
2430 else if (tin > tout)
2433 while (n-- > 0) *jmout++ = *jmin++;
2440 while (n-- > 0) *--jmout = *--jmin;
2446 /*........................................................................*/
2450 /* Routines for management of the dynamic memory. */
2452 /* Routine mcrfree */
2453 /* -------------- */
2455 /* Desallocation of a memory zone . */
2457 /* CALL MCRFREE (IBYTE,IADR,IER) */
2459 /* IBYTE INTEGER*4 : Nb of Octets to free */
2461 /* IADR POINTEUR : Start Address */
2463 /* IER INTEGER*4 : Return Code */
2466 /*........................................................................*/
2469 //=======================================================================
2470 //function : mcrfree_
2472 //=======================================================================
2473 int mcrfree_(integer *,//ibyte,
2479 Standard::Free((void*)iadr);
2483 /*........................................................................*/
2487 /* Routines for management of the dynamic memory. */
2489 /* Routine mcrgetv */
2490 /* -------------- */
2492 /* Demand of memory allocation. */
2494 /* CALL MCRGETV(IBYTE,IADR,IER) */
2496 /* IBYTE (INTEGER*4) Nb of Bytes of allocation required */
2498 /* IADR (INTEGER*4) : Result. */
2500 /* IER (INTEGER*4) : Error Code : */
2503 /* = 1 ==> Allocation impossible */
2504 /* = -1 ==> Ofset > 2**31 - 1 */
2508 /*........................................................................*/
2510 //=======================================================================
2511 //function : mcrgetv_
2513 //=======================================================================
2514 int mcrgetv_(integer *sz,
2521 *iad = (intptr_t)Standard::Allocate(*sz);
2522 if ( !*iad ) *ier = 1;
2527 //=======================================================================
2528 //function : mcrlist_
2530 //=======================================================================
2531 int AdvApp2Var_SysBase::mcrlist_(integer *ier) const
2534 /* System generated locals */
2537 /* Builtin functions */
2539 /* Local variables */
2542 integer ifmt, i__, nufmt, ntotal;
2546 /************************************************************************
2551 /* PRINT TABLE OF CURRENT DYNAMIC ALLOCATIONS */
2555 /* SYSTEM, ALLOCATION, MEMORY, LIST */
2557 /* INPUT ARGUMENTS : */
2558 /* ------------------ */
2561 /* OUTPUT ARGUMENTS : */
2562 /* ------------------- */
2565 /* IERCOD : ERROR CODE */
2567 /* IERCOD = 0 : OK */
2568 /* IERCOD > 0 : SERIOUS ERROR */
2569 /* IERCOD < 0 : WARNING */
2570 /* IERCOD = 1 : ERROR DESCRIPTION */
2571 /* IERCOD = 2 : ERROR DESCRIPTION */
2573 /* COMMONS USED : */
2574 /* ---------------- */
2576 /* MCRGENE VFORMT */
2578 /* REFERENCES CALLED : */
2579 /* ---------------------- */
2584 /* DESCRIPTION/NOTES/LIMITATIONS : */
2585 /* ----------------------------------- */
2591 /* ***********************************************************************
2594 /* INCLUDE MCRGENE */
2595 /* ***********************************************************************
2600 /* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2604 /* SYSTEM, MEMORY, ALLOCATION */
2606 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2607 /* ----------------------------------- */
2611 /* ***********************************************************************
2614 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2615 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2616 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2617 /* 2 : UNIT OF ALLOCATION */
2618 /* 3 : NB OF ALLOCATED UNITS */
2619 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2621 /* 6 : STATIC ALLOCATION NUMBER */
2622 /* 7 : Required allocation size */
2623 /* 8 : address of the beginning of allocation */
2624 /* 9 : Size of the USER ZONE */
2625 /* 10 : ADDRESS of the START FLAG */
2626 /* 11 : ADDRESS of the END FLAG */
2627 /* 12 : Rank of creation of the allocation */
2629 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2630 /* NCORE : NB OF CURRENT ALLOCS */
2631 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2632 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2636 /* ----------------------------------------------------------------------*
2640 /* ----------------------------------------------------------------------*
2644 //__s__copy(subrou, "MCRLIST", 7L, 7L);
2649 ifmt = mcrgene_.ncore;
2650 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2654 i__1 = mcrgene_.ncore;
2655 for (i__ = 0; i__ < i__1; ++i__) {
2657 ifmt = mcrgene_.icore[i__].unit * mcrgene_.icore[i__].reqsize
2659 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2666 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2672 //=======================================================================
2673 //function : mcrlocv_
2675 //=======================================================================
2676 int mcrlocv_(void* t,
2680 *l = reinterpret_cast<intptr_t> (t);
2684 //=======================================================================
2685 //function : AdvApp2Var_SysBase::mcrrqst_
2687 //=======================================================================
2688 int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
2698 /* Local variables */
2702 integer ksys , ibyte, irest, ier;
2703 intptr_t iadfd, iadff, iaddr,lofset, loc;
2707 /* **********************************************************************
2712 /* IMPLEMENTATION OF DYNAMIC MEMORY ALLOCATION */
2716 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
2718 /* INPUT ARGUMENTS : */
2719 /* ------------------ */
2720 /* IUNIT : NUMBER OF OCTET OF THE UNIT OF ALLOCATION */
2721 /* ISIZE : NUMBER OF UNITS REQUIRED */
2722 /* T : REFERENCE ADDRESS */
2724 /* OUTPUT ARGUMENTS : */
2725 /* ------------------- */
2726 /* IOFSET : OFFSET */
2727 /* IERCOD : ERROR CODE, */
2729 /* = 1 : MAX NB OF ALLOCS REACHED */
2730 /* = 2 : ARGUMENTS INCORRECT */
2731 /* = 3 : REFUSED DYNAMIC ALLOCATION */
2733 /* COMMONS USED : */
2734 /* ---------------- */
2735 /* MCRGENE, MCRSTAC */
2737 /* REFERENCES CALLED : */
2738 /* ----------------------- */
2739 /* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
2741 /* DESCRIPTION/NOTES/LIMITATIONS : */
2742 /* ----------------------------------- */
2745 /* -------------- */
2747 /* T IS THE ADDRESS OF A TABLE, IOFSET REPRESENTS THE DEPLACEMENT IN */
2748 /* UNITS OF IUNIT OCTETS BETWEEN THE ALLOCATED ZONE AND TABLE T */
2749 /* IERCOD=0 SIGNALS THAT THE ALLOCATION WORKS WELL, ANY OTHER */
2750 /* VALUE INDICATES A BUG. */
2753 /* LET THE DECLARATION REAL*4 T(1), SO IUNIT=4 . */
2754 /* CALL TO MCRRQST PORODUCES DYNAMIC ALLOCATION */
2755 /* AND GIVES VALUE TO VARIABLE IOFSET, */
2756 /* IF IT IS REQUIRED TO WRITE 1. IN THE 5TH ZONE REAL*4 */
2757 /* ALLOCATED IN THIS WAY, MAKE: */
2758 /* T(5+IOFSET)=1. */
2760 /* CASE OF ERRORS : */
2761 /* --------------- */
2763 /* IERCOD=1 : MAX NB OF ALLOCATION REACHED (ACTUALLY 200) */
2764 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2765 /* "The max number of memory allocation is reached : ,N" */
2767 /* IERCOD=2 : ARGUMENT IUNIT INCORRECT AS IT IS DIFFERENT FROM 1,2,4 OR 8 */
2768 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2769 /* "Unit OF allocation invalid : ,IUNIT" */
2771 /* IERCOD=3 : REFUSED DYNAMIC ALLOCATION (MORE PLACE IN MEMORY) */
2772 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2773 /* "The system refuses dynamic allocation of memory of N octets"
2775 /* with completev display of all allocations carried out till now */
2779 /* -------------- */
2781 /* MCRRQST MAKES DYNAMIC ALLOCATION OF VIRTUAL MEMORY ON THE BASE */
2782 /* OF ENTITIES OF 8 OCTETS (QUADWORDS), WHILE THE ALLOCATION IS REQUIRED BY */
2783 /* UNITS OF IUNIT OCTETS (1,2,4,8). */
2785 /* THE REQUIRED QUANTITY IS IUNIT*ISIZE OCTETS, THIS VALUE IS ROUNDED */
2786 /* SO THAT THE ALLOCATION WAS AN INTEGER NUMBER OF QUADWORDS. */
2791 /* ***********************************************************************
2794 /* COMMON OF PARAMETRES */
2795 /* COMMON OF INFORMATION ON STATISTICS */
2796 /* INCLUDE MCRGENE */
2798 /* ***********************************************************************
2802 /* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2806 /* SYSTEM, MEMORY, ALLOCATION */
2808 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2809 /* ----------------------------------- */
2813 /* ***********************************************************************
2816 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2817 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2818 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2819 /* 2 : UNIT OF ALLOCATION */
2820 /* 3 : NB OF ALLOCATED UNITS */
2821 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2823 /* 6 : STATIC ALLOCATION NUMBER */
2824 /* 7 : Required allocation size */
2825 /* 8 : address of the beginning of allocation */
2826 /* 9 : Size of the USER ZONE */
2827 /* 10 : ADDRESS of the START FLAG */
2828 /* 11 : ADDRESS of the END FLAG */
2829 /* 12 : Rank of creation of the allocation */
2831 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2832 /* NCORE : NB OF CURRENT ALLOCS */
2833 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2834 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2839 /* ----------------------------------------------------------------------*
2841 /* 20-10-86 : BF ; INITIAL VERSION */
2844 /* NRQST : NUMBER OF ALLOCATIONS */
2845 /* NDELT : NUMBER OF LIBERATIONS */
2846 /* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2847 /* MBYTE : MAX NUMBER OF OCTETS */
2850 /* ----------------------------------------------------------------------*
2856 if (mcrgene_.ncore >= MAX_ALLOC_NB) {
2859 if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
2863 /* Calculate the size required by the user */
2864 ibyte = *iunit * *isize;
2866 /* Find the type of version (Phase of Production or Version Client) */
2869 /* Control allocated size in Production phase */
2874 //do__lio(&c__9, &c__1, "Require zero allocation", 26L);
2876 } else if (ibyte >= 4096000) {
2877 //do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L);
2878 //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
2884 /* CALCULATE THE SIZE OF THE USER ZONE (IZU) */
2885 /* . add size required by the user (IBYTE) */
2886 /* . add delta for alinement with the base */
2887 /* . round to multiple of 8 above */
2890 izu = ibyte + loc % *iunit;
2893 izu = izu + 8 - irest;
2896 /* CALCULATE THE SIZE REQUIRED FROM THE PRIMITIVE OF ALLOC */
2897 /* . add size of the user zone */
2898 /* . add 8 for alinement of start address of */
2899 /* allocation on multiple of 8 so that to be able to */
2900 /* set flags with Double Precision without other pb than alignement */
2901 /* . add 16 octets for two flags */
2905 /* DEMAND OF ALLOCATION */
2908 /* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
2909 /* ALLOCATION SUR TABLE */
2912 /* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
2913 /* IF ( IER .NE. 0 ) THEN */
2918 /* ALLOCATION SYSTEME */
2919 ksys = heap_allocation;
2920 mcrgetv_(&ibyte, &iaddr, &ier);
2926 /* CALCULATE THE ADDRESSES OF FLAGS */
2928 iadfd = iaddr + 8 - iaddr % 8;
2929 iadff = iadfd + 8 + izu;
2931 /* CALCULATE USER OFFSET : */
2932 /* . difference between the user start address and the */
2934 /* . converts this difference in the user unit */
2936 lofset = iadfd + 8 + loc % *iunit - loc;
2937 *iofset = lofset / *iunit;
2939 /* If phase of production control flags */
2945 /* . the first flag is set by IADFD and the second by IADFF */
2946 /* . if phase of production, set to overflow the ZU */
2947 macrgfl_(&iadfd, &iadff, &iver, &izu);
2949 /* RANGING OF PARAMETERS IN MCRGENE */
2951 mcrgene_.icore[mcrgene_.ncore].prot = mcrgene_.lprot;
2952 mcrgene_.icore[mcrgene_.ncore].unit = (unsigned char)(*iunit);
2953 mcrgene_.icore[mcrgene_.ncore].reqsize = *isize;
2954 mcrgene_.icore[mcrgene_.ncore].loc = loc;
2955 mcrgene_.icore[mcrgene_.ncore].offset = *iofset;
2956 mcrgene_.icore[mcrgene_.ncore].alloctype = (unsigned char)ksys;
2957 mcrgene_.icore[mcrgene_.ncore].size = ibyte;
2958 mcrgene_.icore[mcrgene_.ncore].addr = iaddr;
2959 mcrgene_.icore[mcrgene_.ncore].userzone = mcrgene_.ncore;
2960 mcrgene_.icore[mcrgene_.ncore].startaddr = iadfd;
2961 mcrgene_.icore[mcrgene_.ncore].endaddr = iadff;
2962 mcrgene_.icore[mcrgene_.ncore].rank = mcrgene_.ncore + 1;
2967 /* CALL ALLOWING AUTOIMPLEMENTATION OF THE SET WATCH BY THE DEBUGGER */
2969 macrstw_(&iadfd, &iadff, &mcrgene_.ncore);
2973 ++mcrstac_.nrqst[ksys];
2974 mcrstac_.nbyte[ksys] += mcrgene_.icore[mcrgene_.ncore - 1].unit *
2975 mcrgene_.icore[mcrgene_.ncore - 1].reqsize;
2977 i__1 = mcrstac_.mbyte[ksys], i__2 = mcrstac_.nbyte[ksys];
2978 mcrstac_.mbyte[ksys] = advapp_max(i__1,i__2);
2982 /* ----------------------------------------------------------------------*
2984 /* ERROR PROCESSING */
2986 /* MAX NB OF ALLOC REACHED : */
2989 ifmt = MAX_ALLOC_NB;
2990 //__s__copy(subr, "MCRRQST", 7L, 7L);
2991 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
2995 /* INCORRECT ARGUMENTS */
2999 //__s__copy(subr, "MCRRQST", 7L, 7L);
3000 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3003 /* SYSTEM REFUSES ALLOCATION */
3007 //__s__copy(subr, "MCRRQST", 7L, 7L);
3008 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3013 /* ----------------------------------------------------------------------*
3021 //=======================================================================
3022 //function : AdvApp2Var_SysBase::mgenmsg_
3024 //=======================================================================
3025 int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
3026 ftnlen )//nomprg_len)
3032 //=======================================================================
3033 //function : AdvApp2Var_SysBase::mgsomsg_
3035 //=======================================================================
3036 int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
3037 ftnlen )//nomprg_len)
3046 C*****************************************************************************
3048 C FUNCTION : CALL MIRAZ(LENGTH,ITAB)
3051 C RESET TO ZERO A TABLE OF LOGIC OR INTEGER.
3058 C ------------------
3059 C LENGTH : NUMBER OF OCTETS TO TRANSFER
3060 C ITAB : NAME OF THE TABLE
3062 C OUTPUT ARGUMENTS :
3063 C -------------------
3064 C ITAB : NAME OF THE TABLE SET TO ZERO
3069 C REFERENCES CALLED :
3070 C ---------------------
3072 C DEMSCRIPTION/NOTES/LIMITATIONS :
3073 C -----------------------------------
3078 C***********************************************************************
3080 //=======================================================================
3081 //function : AdvApp2Var_SysBase::miraz_
3083 //=======================================================================
3084 void AdvApp2Var_SysBase::miraz_(integer *taille,
3088 memset(adt , '\0' , *taille) ;
3090 //=======================================================================
3091 //function : AdvApp2Var_SysBase::mnfndeb_
3093 //=======================================================================
3094 integer AdvApp2Var_SysBase::mnfndeb_()
3101 //=======================================================================
3102 //function : AdvApp2Var_SysBase::msifill_
3104 //=======================================================================
3105 int AdvApp2Var_SysBase::msifill_(integer *nbintg,
3111 /* ***********************************************************************
3116 /* transfer Integer from one zone to another */
3120 /* TRANSFER , INTEGER , MEMORY */
3122 /* INPUT ARGUMENTS : */
3123 /* ------------------ */
3124 /* NBINTG : Nb of integers */
3125 /* IVECIN : Input vector */
3127 /* OUTPUT ARGUMENTS : */
3128 /* ------------------- */
3129 /* IVECOU : Output vector */
3131 /* COMMONS USED : */
3132 /* ---------------- */
3134 /* REFERENCES CALLED : */
3135 /* --------------------- */
3137 /* DESCRIPTION/NOTES/LIMITATIONS : */
3138 /* ----------------------------------- */
3141 /* ***********************************************************************
3144 /* ___ NOCTE : Number of octets to transfer */
3146 /* Parameter adjustments */
3151 nocte = *nbintg * sizeof(integer);
3152 AdvApp2Var_SysBase::mcrfill_(&nocte, &ivecin[1], &ivecou[1]);
3156 //=======================================================================
3157 //function : AdvApp2Var_SysBase::msrfill_
3159 //=======================================================================
3160 int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
3162 doublereal * vecsor)
3167 /* ***********************************************************************
3172 /* Transfer real from one zone to another */
3176 /* TRANSFER , REAL , MEMORY */
3178 /* INPUT ARGUMENTS : */
3179 /* ----------------- */
3180 /* NBREEL : Number of reals */
3181 /* VECENT : Input vector */
3183 /* OUTPUT ARGUMENTS : */
3184 /* ------------------- */
3185 /* VECSOR : Output vector */
3187 /* COMMONS USED : */
3188 /* ---------------- */
3190 /* REFERENCES CALLED : */
3191 /* ----------------------- */
3193 /* DESCRIPTION/NOTES/LIMITATIONS : */
3194 /* ----------------------------------- */
3197 /* ***********************************************************************
3200 /* ___ NOCTE : Nb of octets to transfer */
3202 /* Parameter adjustments */
3207 nocte = *nbreel * sizeof (doublereal);
3208 AdvApp2Var_SysBase::mcrfill_(&nocte, &vecent[1], &vecsor[1]);
3212 //=======================================================================
3213 //function : AdvApp2Var_SysBase::mswrdbg_
3215 //=======================================================================
3216 int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
3217 ftnlen )//ctexte_len)
3221 /* ***********************************************************************
3226 /* Write message on console alpha if IBB>0 */
3230 /* MESSAGE, DEBUG */
3232 /* INPUT ARGUMENTS : */
3233 /* ----------------- */
3234 /* CTEXTE : Text to be written */
3236 /* OUTPUT ARGUMENTS : */
3237 /* ------------------- */
3240 /* COMMONS USED : */
3241 /* ---------------- */
3243 /* REFERENCES CALLED : */
3244 /* ----------------------- */
3246 /* DESCRIPTION/NOTES/LIMITATIONS : */
3247 /* ----------------------------------- */
3251 /* ***********************************************************************
3254 /* ***********************************************************************
3258 /* ***********************************************************************
3261 /* ***********************************************************************
3264 if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
3265 //do__lio(&c__9, &c__1, "Dbg ", 4L);
3266 //do__lio(&c__9, &c__1, ctexte, ctexte_len);
3283 //=======================================================================
3284 //function : do__fio
3286 //=======================================================================
3287 int AdvApp2Var_SysBase::do__fio()
3291 //=======================================================================
3292 //function : do__lio
3294 //=======================================================================
3295 int AdvApp2Var_SysBase::do__lio ()
3301 C*****************************************************************************
3303 C FUNCTION : CALL MVRIRAZ(NBELT,DTAB)
3305 C Reset to zero a table with DOUBLE PRECISION
3312 C ------------------
3313 C NBELT : Number of elements of the table
3314 C DTAB : Table to initializer to zero
3316 C OUTPUT ARGUMENTS :
3317 C --------------------
3318 C DTAB : Table reset to zero
3323 C REFERENCES CALLED :
3324 C -----------------------
3326 C DEMSCRIPTION/NOTES/LIMITATIONS :
3327 C -----------------------------------
3331 C***********************************************************************
3333 //=======================================================================
3334 //function : AdvApp2Var_SysBase::mvriraz_
3336 //=======================================================================
3337 void AdvApp2Var_SysBase::mvriraz_(integer *taille,
3342 offset = *taille * 8 ;
3343 /* printf(" adt %d long %d\n",adt,offset); */
3344 memset(adt , '\0' , offset) ;