1 // Copyright (c) 1999-2012 OPEN CASCADE SAS
3 // The content of this file is subject to the Open CASCADE Technology Public
4 // License Version 6.5 (the "License"). You may not use the content of this file
5 // except in compliance with the License. Please obtain a copy of the License
6 // at http://www.opencascade.org and read it completely before using this file.
8 // The Initial Developer of the Original Code is Open CASCADE S.A.S., having its
9 // main offices at: 1, place des Freres Montgolfier, 78280 Guyancourt, France.
11 // The Original Code and all software distributed under the License is
12 // distributed on an "AS IS" basis, without warranty of any kind, and the
13 // Initial Developer hereby disclaims all such warranties, including without
14 // limitation, any warranties of merchantability, fitness for a particular
15 // purpose or non-infringement. Please see the License for the specific terms
16 // and conditions governing the rights and limitations under the License.
18 // AdvApp2Var_SysBase.cxx
23 #include <AdvApp2Var_Data_f2c.hxx>
24 #include <AdvApp2Var_SysBase.hxx>
25 #include <AdvApp2Var_Data.hxx>
26 #include <Standard.hxx>
39 int macrclw_(intptr_t *iadfld,
43 int macrerr_(intptr_t *iad,
46 int macrgfl_(intptr_t *iadfld,
51 int macrmsg_(const char *crout,
60 int macrstw_(intptr_t *iadfld,
65 int madbtbk_(integer *indice);
68 int magtlog_(const char *cnmlog,
77 int mamdlng_(char *cmdlng,
87 int maoverf_(integer *nbentr,
91 int matrlog_(const char *cnmlog,
99 int matrsym_(const char *cnmsym,
107 int mcrcomm_(integer *kop,
113 int mcrfree_(integer *ibyte,
118 int mcrgetv_(integer *sz,
123 int mcrlocv_(void* t,
128 integer lec, imp, keyb, mae, jscrn, itblt, ibb;
131 #define mcrfill_ABS(a) (((a)<0)?(-(a)):(a))
134 //=======================================================================
135 //function : AdvApp2Var_SysBase
137 //=======================================================================
138 AdvApp2Var_SysBase::AdvApp2Var_SysBase()
141 memset (&mcrstac_, 0, sizeof (mcrstac_));
144 //=======================================================================
145 //function : ~AdvApp2Var_SysBase
147 //=======================================================================
148 AdvApp2Var_SysBase::~AdvApp2Var_SysBase()
150 assert (mcrgene_.ncore == 0); //otherwise memory leaking
153 //=======================================================================
154 //function : macinit_
156 //=======================================================================
157 int AdvApp2Var_SysBase::macinit_(integer *imode,
162 /* Fortran I/O blocks */
163 cilist io______1 = { 0, 0, 0, (char*) "(' --- Debug-mode : ',I10,' ---')", 0 };
165 /* ************************************************************************/
168 /* INITIALIZATION OF READING WRITING UNITS AND 'IBB' */
172 /* MANAGEMENT, CONFIGURATION, UNITS, INITIALIZATION */
174 /* INPUT ARGUMENTS : */
175 /* -------------------- */
176 /* IMODE : MODE of INITIALIZATION :
177 0= DEFAULT, IMP IS 6, IBB 0 and LEC 5 */
178 /* 1= FORCE VALUE OF IMP */
179 /* 2= FORCE VALUE OF IBB */
180 /* 3= FORCE VALUE OF LEC */
182 /* ARGUMENT USED ONLY WHEN IMODE IS 1 OR 2 : */
183 /* IVAL : VALUE OF IMP WHEN IMODE IS 1 */
184 /* VALUE OF IBB WHEN IMODE IS 2 */
185 /* VALUE OF LEC WHEN IMODE IS 3 */
186 /* THERE IS NO CONTROL OF VALIDITY OF VALUE OF IVAL . */
188 /* OUTPUT ARGUMENTS : */
189 /* -------------------- */
194 /* REFERENCES CALLED : */
195 /* ------------------- */
196 /* DESCRIPTION/NOTES/LIMITATIONS : */
197 /* ------------------------------- */
199 /* THIS IS ONLY INITIALIZATION OF THE COMMON BLANK FOR ALL */
200 /* MODULES THAT A PRIORI DO NOT NEED TO KNOW THE COMMONS OF T . */
201 /* WHEN A MODIFICATION OF IBB IS REQUIRED (IMODE=2) AN INFO MESSAGE */
202 /* IS SUBMITTED ON IMP, WITH THE NEW VALUE OF IBB. */
204 /* IBB : MODE DEBUG OF STRIM T : RULES OF USE : */
205 /* 0 RESTRAINED VERSION */
206 /* >0 THE GREATER IS IBB THE MORE COMMENTS THE VERSION HAS. */
207 /* FOR EXAMPLE FOR IBB=1 THE ROUTINES CALLED */
208 /* INFORM ON IMP ('INPUT IN TOTO', */
209 /* AND 'OUTPUT FROM TOTO'), AND THE ROUTINES THAT RETURN */
210 /* NON NULL ERROR CODE INFORM IT AS WELL. */
211 /* (BUT IT IS NOT TRUE FOR ALL ROUTINES OF T) */
213 /* ***********************************************************************
220 } else if (*imode == 1) {
221 mblank__.imp = *ival;
222 } else if (*imode == 2) {
223 mblank__.ibb = *ival;
224 io______1.ciunit = mblank__.imp;
229 do__fio(&c____1, (char *)&mblank__.ibb, (ftnlen)sizeof(integer));
231 AdvApp2Var_SysBase::e__wsfe();
232 } else if (*imode == 3) {
233 mblank__.lec = *ival;
236 /* ----------------------------------------------------------------------*
242 //=======================================================================
243 //function : macrai4_
245 //=======================================================================
246 int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
254 /* ***********************************************************************
259 /* Require dynamic allocation of type INTEGER */
263 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
265 /* INPUT ARGUMENTS : */
266 /* ----------------- */
267 /* NBELEM : Number of required units */
268 /* MAXELM : Max number of units available in ITABLO */
269 /* ITABLO : Reference Address of the rented zone */
271 /* OUTPUT ARGUMENTS : */
272 /* ------------------- */
273 /* IOFSET : Offset */
274 /* IERCOD : Error code */
276 /* = 1 : Max nb of allocations attained */
277 /* = 2 : Incorrect arguments */
278 /* = 3 : Refused dynamic allocation */
281 /* ------------------ */
283 /* REFERENCES CALLED : */
284 /* --------------------- */
287 /* DESCRIPTION/NOTES/LIMITATIONS : */
288 /* ----------------------------------- */
289 /* (Cf description in the heading of MCRRQST) */
291 /* Table ITABLO should be dimensioned to MAXELM by the caller. */
292 /* If the request is lower or equal to MAXELM, IOFSET becomes = 0. */
293 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
295 /* ***********************************************************************
301 iunit = sizeof(integer);
303 if (*nbelem > *maxelm) {
304 /*AdvApp2Var_SysBase::*/mcrrqst_(&iunit, nbelem, itablo, iofset, iercod);
312 //=======================================================================
313 //function : AdvApp2Var_SysBase::macrar8_
315 //=======================================================================
316 int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
325 /* ***********************************************************************
330 /* Demand of dynamic allocation of type DOUBLE PRECISION */
334 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
336 /* INPUT ARGUMENTS : */
337 /* ------------------ */
338 /* NBELEM : Nb of units required */
339 /* MAXELM : Max Nb of units available in XTABLO */
340 /* XTABLO : Reference address of the rented zone */
342 /* OUTPUT ARGUMENTS : */
343 /* ------------------ */
344 /* IOFSET : Offset */
345 /* IERCOD : Error code */
347 /* = 1 : Max Nb of allocations reached */
348 /* = 2 : Arguments incorrect */
349 /* = 3 : Refuse of dynamic allocation */
352 /* ------------------ */
354 /* REFERENCES CALLED : */
355 /* --------------------- */
358 /* DESCRIPTION/NOTES/LIMITATIONS : */
359 /* ----------------------------------- */
360 /* (Cf description in the heading of MCRRQST) */
362 /* Table XTABLO should be dimensioned to MAXELM by the caller. */
363 /* If the request is less or equal to MAXELM, IOFSET becomes = 0. */
364 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
367 /* ***********************************************************************
372 if (*nbelem > *maxelm) {
373 /*AdvApp2Var_SysBase::*/mcrrqst_(&c__8, nbelem, xtablo, iofset, iercod);
381 //=======================================================================
382 //function : macrbrk_
384 //=======================================================================
390 //=======================================================================
391 //function : macrchk_
393 //=======================================================================
394 int AdvApp2Var_SysBase::macrchk_()
396 /* System generated locals */
399 /* Local variables */
405 /* ***********************************************************************
410 /* CONTROL OF EXCESSES OF ALLOCATED MEMORY ZONE */
414 /* SYSTEM, ALLOCATION, MEMORY, CONTROL, EXCESS */
416 /* INPUT ARGUMENTS : */
417 /* ----------------- */
420 /* OUTPUT ARGUMENTS : */
421 /* ------------------- */
425 /* ------------------ */
428 /* REFERENCES CALLED : */
429 /* --------------------- */
430 /* MACRERR, MAOSTRD */
432 /* DESCRIPTION/NOTES/LIMITATIONS : */
433 /* ----------------------------------- */
436 /* ***********************************************************************
439 /* ***********************************************************************
444 /* TABLE OF MANAGEMENT OF DYNAMIC MEMOTY ALLOCATIONS */
448 /* SYSTEM, MEMORY, ALLOCATION */
450 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
451 /* ----------------------------------- */
455 /* ***********************************************************************
458 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
459 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
460 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
461 /* 2 : UNIT OF ALLOCATION */
462 /* 3 : NB OF ALLOCATED UNITS */
463 /* 4 : REFERENCE ADDRESS OF THE TABLE */
465 /* 6 : STATIC ALLOCATION NUMBER */
466 /* 7 : Required allocation size */
467 /* 8 : address of the beginning of allocation */
468 /* 9 : Size of the USER ZONE */
469 /* 10 : ADDRESS of the START FLAG */
470 /* 11 : ADDRESS of the END FLAG */
471 /* 12 : Rank of creation of the allocation */
473 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
474 /* NCORE : NB OF CURRENT ALLOCS */
475 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
476 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
480 /* ----------------------------------------------------------------------*
484 /* ----------------------------------------------------------------------*
487 /* CALCULATE ADDRESS OF T */
489 /* CONTROL OF FLAGS IN THE TABLE */
490 i__1 = mcrgene_.ncore;
491 for (i__ = 0; i__ < i__1; ++i__) {
493 //p to access startaddr and endaddr
494 intptr_t* p = &mcrgene_.icore[i__].startaddr;
495 for (j = 0; j <= 1; ++j) {
496 intptr_t* pp = p + j;
499 ioff = (*pp - loc) / 8;
501 if (t[ioff] != -134744073.) {
503 /* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS
505 /* AND OF RANK ICORE(12,I) */
508 /* BACK-PARCING IN PHASE OF PRODUCTION */
511 /* REMOVAL OF THE ADDRESS OF FLAG TO AVOID REMAKING ITS CONTROL */
526 //=======================================================================
527 //function : macrclw_
529 //=======================================================================
530 int macrclw_(intptr_t *,//iadfld,
538 //=======================================================================
539 //function : AdvApp2Var_SysBase::macrdi4_
541 //=======================================================================
542 int AdvApp2Var_SysBase::macrdi4_(integer *nbelem,
545 intptr_t *iofset, /* Offset long (pmn) */
550 /* ***********************************************************************
555 /* Destruction of dynamic allocation of type INTEGER */
559 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
561 /* INPUT ARGUMENTS : */
562 /* ------------------ */
563 /* NBELEM : Nb of units required */
564 /* MAXELM : Max Nb of units available in ITABLO */
565 /* ITABLO : Reference Address of the allocated zone */
566 /* IOFSET : Offset */
568 /* OUTPUT ARGUMENTS : */
569 /* --------------------- */
570 /* IERCOD : Error Code */
572 /* = 1 : Pb of de-allocation of a zone allocated in table */
573 /* = 2 : The system refuses the demand of de-allocation */
576 /* ------------------ */
578 /* REFERENCES CALLED : */
579 /* --------------------- */
582 /* DESCRIPTION/NOTES/LIMITATIONS : */
583 /* ----------------------------------- */
584 /* (Cf description in the heading of MCRDELT) */
586 /* ***********************************************************************
590 iunit = sizeof(integer);
593 AdvApp2Var_SysBase::mcrdelt_(&iunit,
604 //=======================================================================
605 //function : AdvApp2Var_SysBase::macrdr8_
607 //=======================================================================
608 int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
617 /* ***********************************************************************
622 /* Destruction of dynamic allocation of type DOUBLE PRECISION
627 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
629 /* INPUT ARGUMENTS : */
630 /* -------------------- */
631 /* NBELEM : Nb of units required */
632 /* MAXELM : Max nb of units available in XTABLO */
633 /* XTABLO : Reference Address of the allocated zone */
634 /* IOFSET : Offset */
636 /* OUTPUT ARGUMENTS : */
637 /* ------------------- */
638 /* IERCOD : Error Code */
640 /* = 1 : Pb of de-allocation of a zone allocated on table */
641 /* = 2 : The system refuses the demand of de-allocation */
646 /* REFERENCES CALLEDS : */
647 /* -------------------- */
650 /* DESCRIPTION/NOTES/LIMITATIONS : */
651 /* ----------------------------------- */
652 /* (Cf description in the heading of MCRDELT) */
655 /* ***********************************************************************
660 AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, xtablo, iofset, iercod);
667 //=======================================================================
668 //function : macrerr_
670 //=======================================================================
671 int macrerr_(intptr_t *,//iad,
676 /* Builtin functions */
677 //integer /*s__wsfe(),*/ /*do__fio(),*/ e__wsfe();
679 /* Fortran I/O blocks */
680 //cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
682 /* ***********************************************************************
687 /* WRITING OF ADDRESS REMOVED IN ALLOCS . */
693 /* INPUT ARGUMENTS : */
694 /* ------------------ */
695 /* IAD : ADDRESS TO INFORM OF REMOVAL */
696 /* NALLOC : NUMBER OF ALLOCATION */
698 /* OUTPUT ARGUMENTS : */
699 /* --------------------- */
705 /* REFERENCES CALLED : */
706 /* ------------------- */
708 /* DESCRIPTION/NOTES/LIMITATIONS : */
709 /* ----------------------------------- */
711 /* ***********************************************************************
717 do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
718 do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
719 do__fio(&c__1, " sur l'allocation ", 18L);
720 do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
722 AdvApp2Var_SysBase::e__wsfe();
728 //=======================================================================
729 //function : macrgfl_
731 //=======================================================================
732 int macrgfl_(intptr_t *iadfld,
738 /* Initialized data */
740 /* original code used static integer ifois=0 which served as static
741 initialization flag and was only used to call matrsym_() once; now
742 this flag is not used as matrsym_() always returns 0 and has no
751 intptr_t ioff,iadrfl, iadt;
754 /* ***********************************************************************
759 /* IMPLEMENTATION OF TWO FLAGS START AND END OF THE ALLOCATED ZONE */
760 /* AND SETTING TO OVERFLOW OF THE USER SPACE IN PHASE OF PRODUCTION. */
764 /* ALLOCATION, CONTROL, EXCESS */
766 /* INPUT ARGUMENTS : */
767 /* ------------------ */
768 /* IADFLD : ADDRESS OF THE START FLAG */
769 /* IADFLF : ADDRESS OF THE END FLAG */
770 /* IPHASE : TYPE OF SOFTWARE VERSION : */
771 /* 0 = OFFICIAL VERSION */
772 /* 1 = PRODUCTION VERSION */
773 /* IZNUTI : SIZE OF THE USER ZONE IN OCTETS */
775 /* OUTPUT ARGUMENTS : */
776 /* ------------------ */
780 /* ------------------ */
782 /* REFERENCES CALLED : */
783 /* ------------------- */
786 /* DESCRIPTION/NOTES/LIMITATIONS : */
787 /* ------------------------------- */
790 /* ***********************************************************************
795 /* ***********************************************************************
800 /* TABLE FOR MANAGEMENT OF DYNAMIC ALLOCATIONS OF MEMORY */
804 /* SYSTEM, MEMORY, ALLOCATION */
806 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
807 /* ----------------------------------- */
811 /* ***********************************************************************
813 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
814 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
815 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
816 /* 2 : UNIT OF ALLOCATION */
817 /* 3 : NB OF ALLOCATED UNITS */
818 /* 4 : REFERENCE ADDRESS OF THE TABLE */
820 /* 6 : STATIC ALLOCATION NUMBER */
821 /* 7 : Required allocation size */
822 /* 8 : address of the beginning of allocation */
823 /* 9 : Size of the USER ZONE */
824 /* 10 : ADDRESS of the START FLAG */
825 /* 11 : ADDRESS of the END FLAG */
826 /* 12 : Rank of creation of the allocation */
828 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
829 /* NCORE : NB OF CURRENT ALLOCS */
830 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
831 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
837 /* ----------------------------------------------------------------------*
842 matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
846 /* CALCULATE THE ADDRESS OF T */
849 /* CALCULATE THE OFFSET */
850 ioff = (*iadfld - iadt) / 8;
852 /* SET TO OVERFLOW OF THE USER ZONE IN CASE OF PRODUCTION VERSION */
853 if (*iphase == 1 && novfl == 0) {
855 maoverf_(&ienr, &t[ioff + 1]);
858 /* UPDATE THE START FLAG */
859 t[ioff] = -134744073.;
861 /* FAKE CALL TO STOP THE DEBUGGER : */
865 /* UPDATE THE START FLAG */
866 ioff = (*iadflf - iadt) / 8;
867 t[ioff] = -134744073.;
869 /* FAKE CALL TO STOP THE DEBUGGER : */
876 //=======================================================================
877 //function : macrmsg_
879 //=======================================================================
880 int macrmsg_(const char *,//crout,
890 /* Local variables */
891 integer inum, iunite;
892 char cfm[80], cln[3];
894 /* Fortran I/O blocks */
895 cilist io___5 = { 0, 0, 0, cfm, 0 };
896 cilist io___6 = { 0, 0, 0, cfm, 0 };
897 cilist io___7 = { 0, 0, 0, cfm, 0 };
900 /* ***********************************************************************
905 /* MESSAGING OF ROUTINES OF ALLOCATION */
911 /* INPUT ARGUMENTSEE : */
912 /* ------------------- */
913 /* CROUT : NAME OF THE CALLING ROUTINE : MCRRQST, MCRDELT, MCRLIST
915 /* ,CRINCR OR CRPROT */
916 /* NUM : MESSAGE NUMBER */
917 /* IT : TABLE OF INTEGER DATA */
918 /* XT : TABLE OF REAL DATA */
919 /* CT : ------------------ CHARACTER */
921 /* OUTPUT ARGUMENTS : */
922 /* --------------------- */
926 /* ------------------ */
928 /* REFERENCES CALLED : */
929 /* --------------------- */
931 /* DESCRIPTION/NOTES/LIMITATIONS : */
932 /* ----------------------------------- */
934 /* ROUTINE FOR TEMPORARY USE, WAITING FOR THE 'NEW' MESSAGE */
935 /* (STRIM 3.3 ?), TO MAKE THE ROUTINES OF ALLOC USABLE */
938 /* DEPENDING ON THE LANGUAGE, WRITING OF THE REQUIRED MESSAGE ON */
940 /* (REUSE OF SPECIFS OF VFORMA) */
942 /* THE MESSAGE IS INITIALIZED AT 'MESSAGE MISSING', AND IT IS */
943 /* REPLACED BY THE REQUIRED MESSAGE IF EXISTS. */
945 /* ***********************************************************************
950 /* ----------------------------------------------------------------------*
952 /* FIND MESSAGE DEPENDING ON THE LANGUAGE , THE ROUTINE */
953 /* AND THE MESSAGE NUMBER */
955 /* READING OF THE LANGUAGE : */
956 /* Parameter adjustments */
964 /* INUM : TYPE OF MESSAGE : 0 AS TEXT, 1 1 INTEGER TO BE WRITTEN */
965 /* -1 MESSAGE INEXISTING (1 INTEGER AND 1 CHAIN) */
969 if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
970 __s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
971 e de nom : ',A8)", 80L, 71L);
972 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
975 __s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
976 ee(s) : ',I6,/)", 80L, 62L);
977 } else if (*num == 2) {
979 __s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
980 } else if (*num == 3) {
982 __s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
984 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
987 __s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
988 e pas ')", 80L, 56L);
989 } else if (*num == 2) {
991 __s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
992 ion de memoire ')", 80L, 65L);
994 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
997 __s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
998 atteint :',I6)", 80L, 62L);
999 } else if (*num == 2) {
1001 __s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
1003 } else if (*num == 3) {
1005 __s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
1006 de ',I12,' octets')", 80L, 66L);
1008 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1011 __s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
1012 iste pas')", 80L, 57L);
1014 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1017 __s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
1018 ) : ',I12)", 80L, 57L);
1022 } else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
1023 __s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
1024 mm des Namens : ',A8)", 80L, 76L);
1025 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1028 __s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
1029 sung(en) : ',I6,/)", 80L, 65L);
1030 } else if (*num == 2) {
1032 __s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
1033 } else if (*num == 3) {
1035 __s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
1038 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1041 __s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
1042 nicht !! ')", 80L, 59L);
1043 } else if (*num == 2) {
1045 __s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
1046 Zuweisung !!')", 80L, 61L);
1048 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1051 __s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
1052 icht :',I6)", 80L, 58L);
1053 } else if (*num == 2) {
1055 __s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
1057 } else if (*num == 3) {
1059 __s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
1060 ,I12,' Bytes')", 80L, 61L);
1062 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1065 __s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
1066 stiert nicht !! ')", 80L, 65L);
1068 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1071 __s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
1072 : ',I12)", 80L, 55L);
1077 __s__copy(cfm, "(' Message number ',I5,' is missing ' \
1078 ,'for program named: ',A8)", 80L, 93L);
1079 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1082 __s__copy(cfm, "(/,' number of memory allocations carried out: \
1083 ',I6,/)", 80L, 54L);
1084 } else if (*num == 2) {
1086 __s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
1087 } else if (*num == 3) {
1089 __s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
1091 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1094 __s__copy(cfm, "(' Memory allocation to delete does not exist !\
1096 } else if (*num == 2) {
1098 __s__copy(cfm, "(' System refuses deletion of memory allocation\
1101 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1104 __s__copy(cfm, "(' max number of memory allocations reached :',\
1106 } else if (*num == 2) {
1108 __s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
1110 } else if (*num == 3) {
1112 __s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
1113 ' bytes ')", 80L, 57L);
1115 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1118 __s__copy(cfm, "(' Memory allocation to increment does not exis\
1119 t !! ')", 80L, 54L);
1121 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1124 __s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
1130 /* ----------------------------------------------------------------------*
1132 /* iMPLEMENTATION OF WRITE , WITH OR WITHOUT DATA : */
1134 iunite = AdvApp2Var_SysBase::mnfnimp_();
1136 io___5.ciunit = iunite;
1140 AdvApp2Var_SysBase::e__wsfe();
1141 } else if (inum == 1) {
1142 io___6.ciunit = iunite;
1147 do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
1149 AdvApp2Var_SysBase::e__wsfe();
1151 /* MESSAGE DOES NOT EXIST ... */
1152 io___7.ciunit = iunite;
1157 do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
1158 do__fio(&c__1, crout, crout_len);
1160 AdvApp2Var_SysBase::e__wsfe();
1165 //=======================================================================
1166 //function : macrstw_
1168 //=======================================================================
1169 int macrstw_(intptr_t *,//iadfld,
1170 intptr_t *,//iadflf,
1177 //=======================================================================
1178 //function : madbtbk_
1180 //=======================================================================
1181 int madbtbk_(integer *indice)
1187 //=======================================================================
1188 //function : AdvApp2Var_SysBase::maermsg_
1190 //=======================================================================
1191 int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
1193 ftnlen )//cnompg_len)
1199 //=======================================================================
1200 //function : magtlog_
1202 //=======================================================================
1203 int magtlog_(const char *cnmlog,
1204 const char *,//chaine,
1208 ftnlen )//chaine_len)
1212 /* Local variables */
1217 /* **********************************************************************
1222 /* RETURN TRANSLATION OF "NAME LOGIC STRIM" IN */
1223 /* "INTERNAL SYNTAX" CORRESPONDING TO "PLACE OF RANKING" */
1227 /* NOM LOGIQUE STRIM , TRADUCTION */
1229 /* INPUT ARGUMENTS : */
1230 /* ------------------ */
1231 /* CNMLOG : NAME OF "NAME LOGIC STRIM" TO TRANSLATE */
1233 /* OUTPUT ARGUMENTS : */
1234 /* ------------------- */
1235 /* CHAINE : ADDRESS OF "PLACE OF RANKING" */
1236 /* LONG : USEFUL LENGTH OF "PLACE OF RANKING" */
1237 /* IERCOD : ERROR CODE */
1238 /* IERCOD = 0 : OK */
1239 /* IERCOD = 5 : PLACE OF RANKING CORRESPONDING TO INEXISTING LOGIC NAME */
1241 /* IERCOD = 6 : TRANSLATION TOO LONG FOR THE 'CHAIN' VARIABLE */
1242 /* IERCOD = 7 : CRITICAL ERROR */
1244 /* COMMONS USED : */
1245 /* ---------------- */
1248 /* REFERENCES CALLED : */
1249 /* --------------------- */
1250 /* GNMLOG, MACHDIM */
1252 /* DESCRIPTION/NOTES/LIMITATIONS : */
1253 /* ------------------------------- */
1255 /* SPECIFIC SGI ROUTINE */
1257 /* IN ALL CASES WHEN IERCOD IS >0, NO RESULT IS RETURNED*/
1258 /* NOTION OF "USER SYNTAX' AND "INTERNAL SYNTAX" */
1259 /* --------------------------------------------------- */
1261 /* THE "USER SYNTAX" IS THE SYNTAX WHERE THE USER*/
1262 /* VISUALIZES OR INDICATES THE FILE OR DIRECTORY NAME */
1263 /* DURING A SESSION OF STRIM100 */
1265 /* "INTERNAL SYNTAX" IS SYNTAX USED TO CARRY OUT */
1266 /* OPERATIONS OF FILE PROCESSING INSIDE THE CODE */
1267 /* (OPEN,INQUIRE,...ETC) */
1270 /* ***********************************************************************
1273 /* ***********************************************************************
1277 /* ***********************************************************************
1280 /* ***********************************************************************
1286 /* CONTROL OF EXISTENCE OF THE LOGIC NAME */
1288 matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
1296 /* CONTROL OF THE LENGTH OF CHAIN */
1298 if (ibid > __i__len()/*chaine, chaine_len)*/) {
1302 //__s__copy(chaine, cbid, chaine_len, ibid);
1307 /* ***********************************************************************
1309 /* ERROR PROCESSING */
1310 /* ***********************************************************************
1315 //__s__copy(chaine, " ", chaine_len, 1L);
1320 //__s__copy(chaine, " ", chaine_len, 1L);
1325 //__s__copy(chaine, " ", chaine_len, 1L);
1327 /* ***********************************************************************
1329 /* RETURN TO THE CALLING PROGRAM */
1330 /* ***********************************************************************
1337 //=======================================================================
1338 //function : mainial_
1340 //=======================================================================
1341 int AdvApp2Var_SysBase::mainial_()
1348 //=======================================================================
1349 //function : AdvApp2Var_SysBase::maitbr8_
1351 //=======================================================================
1352 int AdvApp2Var_SysBase::maitbr8_(integer *itaill,
1357 integer c__504 = 504;
1359 /* Initialized data */
1361 doublereal buff0[63] = {
1362 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1363 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1364 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1368 /* System generated locals */
1371 /* Local variables */
1373 doublereal buffx[63];
1374 integer nbfois, noffst, nreste, nufois;
1376 /* ***********************************************************************
1381 /* INITIALIZATION TO A GIVEN VALUE OF A TABLE OF REAL *8 */
1385 /* MANIPULATIONS, MEMORY, INITIALIZATION, DOUBLE-PRECISION */
1387 /* INPUT ARGUMENTS : */
1388 /* ----------------- */
1389 /* ITAILL : SIZE OF THE TABLE */
1390 /* XTAB : TABLE TO INITIALIZE WITH XVAL */
1391 /* XVAL : VALUE TO SET IN XTAB(FROM 1 TO ITAILL) */
1393 /* OUTPUT ARGUMENTS : */
1394 /* ------------------ */
1395 /* XTAB : INITIALIZED TABLE */
1397 /* COMMONS USED : */
1398 /* -------------- */
1400 /* REFERENCES CALLED : */
1401 /* ------------------- */
1403 /* DESCRIPTION/NOTES/LIMITATIONS : */
1404 /* ----------------------------------- */
1406 /* ONE CALLS MCRFILL WHICH MOVES BY PACKS OF 63 REALS */
1408 /* THE INITIAL PACK IS BUFF0 INITIATED BY DATA IF THE VALUE IS 0 */
1409 /* OR OTHERWISE BUFFX INITIATED BY XVAL (LOOP). */
1412 /* PORTABILITY : YES */
1417 /* ***********************************************************************
1421 /* Parameter adjustments */
1426 /* ----------------------------------------------------------------------*
1429 nbfois = *itaill / 63;
1430 noffst = nbfois * 63;
1431 nreste = *itaill - noffst;
1436 for (nufois = 1; nufois <= i__1; ++nufois) {
1437 AdvApp2Var_SysBase::mcrfill_(&c__504, buff0, &xtab[(nufois - 1) * 63 + 1]);
1444 AdvApp2Var_SysBase::mcrfill_(&i__1, buff0, &xtab[noffst + 1]);
1447 for (i__ = 1; i__ <= 63; ++i__) {
1448 buffx[i__ - 1] = *xval;
1453 for (nufois = 1; nufois <= i__1; ++nufois) {
1454 AdvApp2Var_SysBase::mcrfill_(&c__504, buffx, &xtab[(nufois - 1) * 63 + 1]);
1461 AdvApp2Var_SysBase::mcrfill_(&i__1, buffx, &xtab[noffst + 1]);
1465 /* ----------------------------------------------------------------------*
1471 //=======================================================================
1472 //function : mamdlng_
1474 //=======================================================================
1475 int mamdlng_(char *,//cmdlng,
1476 ftnlen )//cmdlng_len)
1481 /* ***********************************************************************
1486 /* RETURN THE CURRENT LANGUAGE */
1490 /* MANAGEMENT, CONFIGURATION, LANGUAGE, READING */
1492 /* INPUT ARGUMENTS : */
1493 /* -------------------- */
1494 /* CMDLNG : LANGUAGE */
1496 /* OUTPUT ARGUMENTS : */
1497 /* ------------------- */
1500 /* COMMONS USED : */
1501 /* ------------------ */
1504 /* REFERENCES CALLED : */
1505 /* --------------------- */
1508 /* DESCRIPTION/NOTES/LIMITATIONS : */
1509 /* ----------------------------------- */
1510 /* RIGHT OF USAGE : ANY APPLICATION */
1512 /* ATTENTION : THIS ROUTINE DEPENDS ON PRELIMINARY INITIALISATION */
1513 /* ---------- WITH AMDGEN. */
1514 /* SO IT IS ENOUGH TO PROVIDE THAT THIS INIT IS */
1515 /* CORRECTLY IMPLEMENTED IN THE RESPECTIVE PROGRAMS */
1517 /* ***********************************************************************
1521 /* INCLUDE MACETAT */
1524 /* ***********************************************************************
1529 /* CONTAINS INFORMATIONS ABOUT THE COMPOSITION OF */
1530 /* THE EXECUTABLE AND ITS ENVIRONMENT : */
1532 /* - PRESENT APPLICATIONS */
1533 /* - AUTHORIZED TYPES OF ENTITIES (NON USED) */
1534 /* AND INFORMATION DESCRIBING THE CURRENT STATE : */
1535 /* - CURRENT APPLICATION */
1536 /* - MODE OF USAGE (NOT USED) */
1540 /* APPLICATION, LANGUAGE */
1542 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
1543 /* ----------------------------------- */
1545 /* A) CHLANG*4 : LIST OF POSSIBLE VALUES OF THE LANGUAGE : */
1546 /* 'FRA ','DEU ','ENG ' */
1548 /* CHL10N*4 : LIST OF POSSIBLE VALUES OF THE LOCALIZATION : */
1549 /* 'FRA ','DEU ','ENG ', 'JIS ' */
1551 /* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : CURRENT, PREVIOUS AND NEXT APPLICATION
1553 /* C) CHMODE*4 : CURRENT MODE (NOT USED) */
1555 /* D) CHPRES*2 (1:NBRMOD) : LIST OF APPLICATIONS TAKEN INTO ACCOUNT */
1557 /* Rang ! Code interne ! Application */
1558 /* ---------------------------------------------------------- */
1559 /* 1 ! CD ! Modeling 2D */
1560 /* 2 ! CA ! Modeling 2D by learning */
1561 /* 3 ! CP ! Parameterized 2D modelization */
1562 /* 4 ! PC ! Rheological 2D modelization */
1563 /* 5 ! CU ! Milling 2 Axes 1/2 */
1564 /* 6 ! CT ! Turning */
1565 /* 7 ! TS ! 3D surface modeling */
1566 /* 8 ! TV ! 3D volume modeling */
1567 /* 9 ! MC ! Surface Meshing */
1568 /* 10 ! MV ! Volume Meshing */
1569 /* 11 ! TU ! Machining by 3 axes */
1570 /* 12 ! T5 ! Machining by 3-5 axes */
1571 /* 13 ! TR ! Machinning by 5 axes of regular surfaces */
1572 /* 14 ! IG ! Interface IGES */
1573 /* 15 ! ST ! Interface SET */
1574 /* 16 ! VD ! Interface VDA */
1575 /* 17 ! IM ! Interface of modeling */
1576 /* 18 ! GA ! Generator APT/IFAPT */
1577 /* 19 ! GC ! Generator COMPACT II */
1578 /* 20 ! GP ! Generator PROMO */
1579 /* 21 ! TN ! Machining by numerical copying */
1580 /* 22 ! GM ! Management of models */
1581 /* 23 ! GT ! Management of trace */
1582 /* ---------------------------------------------------------- */
1587 /* ***********************************************************************
1590 /* NUMBER OF APPLICATIONS TAKEN INTO ACCOUNT */
1593 /* NUMBER OF ENTITY TYPES MANAGED BY STRIM 100 */
1594 //__s__copy(cmdlng, macetat_.chlang, cmdlng_len, 4L);
1599 //=======================================================================
1600 //function : maostrb_
1602 //=======================================================================
1608 //=======================================================================
1609 //function : maostrd_
1611 //=======================================================================
1616 /* ***********************************************************************
1621 /* REFINE TRACE-BACK IN PRODUCTION PHASE */
1625 /* FUNCTION, SYSTEM, TRACE-BACK, REFINING, DEBUG */
1627 /* INPUT ARGUMENTS : */
1628 /* ----------------- */
1631 /* OUTPUT ARGUMENTS E : */
1632 /* -------------------- */
1635 /* COMMONS USED : */
1636 /* -------------- */
1639 /* REFERENCES CALLED : */
1640 /* ------------------- */
1643 /* DESCRIPTION/NOTES/LIMITATIONS : */
1644 /* ----------------------------------- */
1645 /* THIS ROUTINE SHOULD BE CALLED TO REFINE */
1646 /* TRACE-BACK IN PRODUCTION PHASE AND LEAVE TO TESTERS THE */
1647 /* POSSIBILITY TO GET TRACE-BACK IN */
1648 /* CLIENT VERSIONS IF ONE OF THE FOLLOWING CONDITIONS IS */
1650 /* - EXISTENCE OF SYMBOL 'STRMTRBK' */
1651 /* - EXISTENCE OF FILE 'STRMINIT:STRMTRBK.DAT' */
1655 /* ***********************************************************************
1664 //=======================================================================
1665 //function : maoverf_
1667 //=======================================================================
1668 int maoverf_(integer *nbentr,
1672 /* Initialized data */
1676 /* System generated locals */
1679 /* Local variables */
1681 doublereal buff[63];
1682 integer ioct, indic, nrest, icompt;
1684 /* ***********************************************************************
1689 /* Initialisation in overflow of a tableau with DOUBLE PRECISION */
1693 /* MANIPULATION, MEMORY, INITIALISATION, OVERFLOW */
1695 /* INPUT ARGUMENTS : */
1696 /* ----------------- */
1697 /* NBENTR : Number of entries in the table */
1699 /* OUTPUT ARGUMENTS : */
1700 /* ------------------ */
1701 /* DATBLE : Table double precision initialized in overflow */
1703 /* COMMONS USED : */
1704 /* ------------------ */
1705 /* R8OVR contained in the include MAOVPAR.INC */
1707 /* REFERENCES CALLED : */
1708 /* --------------------- */
1711 /* DESCRIPTION/NOTES/LIMITATIONS : */
1712 /* ----------------------------------- */
1713 /* 1) Doc. programmer : */
1715 /* This routine initialized to positive overflow a table with */
1716 /* DOUBLE PRECISION. */
1718 /* Other types of tables (INTEGER*2, INTEGER, REAL, ...) */
1719 /* are not managed by the routine. */
1721 /* It is usable in phase of developpement to detect the */
1722 /* errors of initialization. */
1724 /* In official version, these calls will be inactive. */
1726 /* ACCESs : Agreed with AC. */
1728 /* The routine does not return error code. */
1730 /* Argument NBELEM should be positive. */
1731 /* If it is negative or null, display message "MAOVERF : NBELEM = */
1732 /* valeur_de_NBELEM" and a Trace Back by the call of routine MAOSTRB. */
1735 /* 2) Doc. designer : */
1737 /* The idea is to minimize the number of calls */
1738 /* to the routine of transfer of numeric zones, */
1739 /* ---------- for the reason of performance. */
1740 /* ! buffer ! For this a table of NLONGR
1741 /* !__________! DOUBLE PRECISIONs is reserved. This buffer is initialized by */
1742 /* <----------> the instruction DATA. The overflow is accessed in a */
1743 /* NLONGR*8 specific COMMON not by a routine as */
1744 /* the initialisation is done by DATA. */
1746 /* * If NBENTR<NLONGR, a part of the buffer is transfered*/
1747 /* DTABLE in DTABLE. */
1749 /* ! amorce ! * Otherwise, the entire buffer is transfered in DTABLE. */
1750 /* !__________! This initiates it. Then a loop is execute, which at each
1752 /* ! temps 1 ! iteration transfers the part of the already initialized table */
1753 /* !__________! in the one that was not yet initialized. */
1754 /* ! ! The size of the zone transfered by each call to MCRFILL
1756 /* ! temps 2 ! is NLONGR*2**(numero_de_l'iteration). When
1758 /* ! ! the size of the table to be initialized is */
1759 /* !__________! less than the already initialized size, the loop is */
1760 /* ! ! abandoned and thev last transfer is carried out to */
1761 /* ! ! initialize the remaining table, except for the case when the size */
1762 /* ! ! of the table is of type NLONGR*2**K. */
1764 /* ! ! * NLONGR will be equal to 19200. */
1773 /* ***********************************************************************
1776 /* Inclusion of MAOVPAR.INC */
1779 /* INCLUDE MAOVPAR */
1780 /* ***********************************************************************
1785 /* DEFINES SPECIFIC LIMITED VALUES. */
1789 /* SYSTEM, LIMITS, VALUES, SPECIFIC */
1791 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
1792 /* ----------------------------------- */
1793 /* *** THEY CAN'T BE REMOVED DURING EXECUTION. */
1795 /* *** THE VALUES OF UNDERFLOW AND OVERFLOW CAN'T BE */
1796 /* DEFINED IN DECIMAL VALUES (ERROR OF COMPILATION D_FLOAT) */
1797 /* THEY ARE DEFINED AS HEXADECIMAL VALUES */
1801 /* ***********************************************************************
1805 /* DECLARATION OF THE COMMON FOR NUMERIC TYPES */
1808 /* DECLARATION OF THE COMMON FOR CHARACTER TYPES*/
1812 /* LOCAL VARIABLES */
1817 /* Parameter adjustments */
1822 /* vJMB R8OVR IS NOT YET initialized, so impossible to use DATA
1824 /* DATA BUFF / NLONGR * R8OVR / */
1826 /* init of BUFF is done only once */
1829 for (icompt = 1; icompt <= 63; ++icompt) {
1830 buff[icompt - 1] = maovpar_.r8ovr;
1839 nrest = *nbentr << 3;
1840 AdvApp2Var_SysBase::mcrfill_(&nrest, buff, &dtable[1]);
1843 /* Start & initialization */
1845 AdvApp2Var_SysBase::mcrfill_(&ioct, buff, &dtable[1]);
1848 /* Loop. The upper limit is the integer value of the logarithm of base 2
1850 /* of NBENTR/NLONGR. */
1851 i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.))
1853 for (ibid = 1; ibid <= i__1; ++ibid) {
1855 AdvApp2Var_SysBase::mcrfill_(&ioct, &dtable[1], &dtable[indic + 1]);
1862 nrest = ( *nbentr - indic ) << 3;
1865 AdvApp2Var_SysBase::mcrfill_(&nrest, &dtable[1], &dtable[indic + 1]);
1872 //=======================================================================
1873 //function : AdvApp2Var_SysBase::maovsr8_
1875 //=======================================================================
1876 int AdvApp2Var_SysBase::maovsr8_(integer *ivalcs)
1878 *ivalcs = maovpar_.r8ncs;
1882 //=======================================================================
1883 //function : matrlog_
1885 //=======================================================================
1886 int matrlog_(const char *,//cnmlog,
1887 const char *,//chaine,
1890 ftnlen ,//cnmlog_len,
1891 ftnlen )//chaine_len)
1900 //=======================================================================
1901 //function : matrsym_
1903 //=======================================================================
1904 int matrsym_(const char *cnmsym,
1905 const char *,//chaine,
1909 ftnlen )//chaine_len)
1912 /* Local variables */
1915 /* ***********************************************************************
1920 /* RETURN THE VALUE OF A SYMBOL DEFINED DURING THE */
1921 /* INITIALISATION OF A USER */
1925 /* TRANSLATION, SYMBOL */
1927 /* INPUT ARGUMENTS : */
1928 /* -------------------- */
1929 /* CNMSYM : NAME OF THE SYMBOL */
1931 /* OUTPUT ARGUMENTS : */
1932 /* ------------------ */
1933 /* CHAINE : TRANSLATION OF THE SYMBOL */
1934 /* LENGTH : USEFUL LENGTH OF THE CHAIN */
1935 /* IERCOD : ERROR CODE */
1937 /* = 1 : INEXISTING SYMBOL */
1938 /* = 2 : OTHER ERROR */
1940 /* COMMONS USED : */
1941 /* ------------------ */
1944 /* REFERENCES CALLED : */
1945 /* --------------------- */
1946 /* LIB$GET_SYMBOL,MACHDIM */
1948 /* DESCRIPTION/NOTES/LIMITATIONS : */
1949 /* ----------------------------------- */
1950 /* - THIS ROUTINE IS VAX SPECIFIC */
1951 /* - IN CASE OF ERROR (IERCOD>0), CHAIN = ' ' AND LENGTH = 0 */
1952 /* - IF THE INPUT VARIABLE CNMSYM IS EMPTY, THE ROUTINE RETURNS IERCOD=1*/
1954 /* ***********************************************************************
1960 /* SGI CALL MAGTLOG (CNMSYM,CHAINE,LENGTH,IERCOD) */
1961 magtlog_(cnmsym, chainx, length, iercod, cnmsym_len, 255L);
1970 //if (__s__cmp(chainx, "NONE", 255L, 4L) == 0) {
1971 if (__s__cmp() == 0) {
1972 //__s__copy(chainx, " ", 255L, 1L);
1975 //__s__copy(chaine, chainx, chaine_len, 255L);
1979 /* ***********************************************************************
1981 /* ERROR PROCESSING */
1982 /* ***********************************************************************
1990 //=======================================================================
1991 //function : mcrcomm_
1993 //=======================================================================
1994 int mcrcomm_(integer *kop,
2000 /* Initialized data */
2004 /* System generated locals */
2007 /* Local variables */
2009 doublereal dtab[32000];
2010 intptr_t itab[160] /* was [4][40] */;
2015 /************************************************************************
2020 /* DYNAMIC ALLOCATION ON COMMON */
2024 /* . ALLOCDYNAMIQUE, MEMORY, COMMON, ALLOC */
2026 /* INPUT ARGUMENTS : */
2027 /* ------------------ */
2028 /* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */
2029 /* NOCT : NUMBER OF OCTETS */
2031 /* OUTPUT ARGUMENTS : */
2032 /* ------------------- */
2033 /* IADR : ADDRESS IN MEMORY OF THE FIRST OCTET */
2036 /* IERCOD : ERROR CODE */
2038 /* IERCOD = 0 : OK */
2039 /* IERCOD > 0 : CRITICAL ERROR */
2040 /* IERCOD < 0 : WARNING */
2041 /* IERCOD = 1 : ERROR DESCRIPTION */
2042 /* IERCOD = 2 : ERROR DESCRIPTION */
2044 /* COMMONS USED : */
2045 /* ---------------- */
2049 /* REFERENCES CALLED : */
2050 /* ---------------------- */
2055 /* DESCRIPTION/NOTES/LIMITATIONS : */
2056 /* ----------------------------------- */
2058 /* ATTENTION .... ITAB ARE NTAB NOT SAVED BETWEEN 2 CALLS..
2062 /* ***********************************************************************
2065 /* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */
2067 /* ITAB : TABLE OF MANAGEMENT OF DTAB, ALLOCATED MEMORY ZONE . */
2068 /* NTAB : NUMBER OF COMPLETED ALLOCATIONS. */
2069 /* FORMAT OF ITAB : NUMBER OF ALLOCATED REAL*8, ADDRESS OF THE 1ST REAL*8
2071 /* , NOCT , VIRTUAL ADDRESS */
2073 /* PP COMMON / CRGEN2 / DTAB */
2076 /* ----------------------------------------------------------------------*
2081 /* ALLOCATION : FIND A HOLE */
2095 for (i__ = 1; i__ <= i__1; ++i__) {
2099 ipre = itab[((i__ - 1) << 2) - 3] + itab[((i__ - 1) << 2) - 4];
2102 ideb = itab[(i__ << 2) - 3];
2106 if ((ideb - ipre) << 3 >= *noct) {
2107 /* A HOLE WAS FOUND */
2109 for (j = ntab; j >= i__2; --j) {
2110 for (k = 1; k <= 4; ++k) {
2111 itab[k + ((j + 1) << 2) - 5] = itab[k + (j << 2) - 5];
2117 itab[(i__ << 2) - 4] = *noct / 8 + 1;
2118 itab[(i__ << 2) - 3] = ipre;
2119 itab[(i__ << 2) - 2] = *noct;
2120 mcrlocv_(&dtab[ipre - 1], iadr);
2121 itab[(i__ << 2) - 1] = *iadr;
2132 /* ----------------------------------- */
2133 /* DESTRUCTION OF THE ALLOCATION NUM : */
2137 for (i__ = 1; i__ <= i__1; ++i__) {
2138 if (*noct != itab[(i__ << 2) - 2]) {
2141 if (*iadr != itab[(i__ << 2) - 1]) {
2144 /* THE ALLOCATION TO BE REMOVED WAS FOUND */
2146 for (j = i__ + 1; j <= i__2; ++j) {
2147 for (k = 1; k <= 4; ++k) {
2148 itab[k + ((j - 1) << 2) - 5] = itab[k + (j << 2) - 5];
2159 /* THE ALLOCATION DOES NOT EXIST */
2169 //=======================================================================
2170 //function : AdvApp2Var_SysBase::mcrdelt_
2172 //=======================================================================
2173 int AdvApp2Var_SysBase::mcrdelt_(integer *iunit,
2182 integer noct, iver, ksys, i__, n, nrang,
2184 intptr_t iadfd, iadff, iaddr, loc; /* Les adrresses en long*/
2187 /* ***********************************************************************
2192 /* DESTRUCTION OF A DYNAMIC ALLOCATION */
2196 /* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
2198 /* INPUT ARGUMENTS : */
2199 /* ------------------ */
2200 /* IUNIT : NUMBER OF OCTETS OF THE ALLOCATION UNIT */
2201 /* ISIZE : NUMBER OF UNITS REQUIRED */
2202 /* T : REFERENCE ADDRESS */
2203 /* IOFSET : OFFSET */
2205 /* OUTPUT ARGUMENTS : */
2206 /* ------------------- */
2207 /* IERCOD : ERROR CODE */
2209 /* = 1 : PB OF DE-ALLOCATION OF A ZONE ALLOCATED IN COMMON */
2210 /* = 2 : THE SYSTEM REFUSES TO DEMAND DE-ALLOCATION */
2211 /* = 3 : THE ALLOCATION TO BE DESTROYED DOES NOT EXIST. */
2213 /* COMMONS USED : */
2214 /* ---------------- */
2217 /* REFERENCES CALLED : */
2218 /* --------------------- */
2221 /* DESCRIPTION/NOTES/LIMITATIONS : */
2222 /* ----------------------------------- */
2224 /* 1) UTILISATEUR */
2227 /* MCRDELT FREES ALLOCATED MEMORY ZONE */
2228 /* BY ROUTINE MCRRQST (OR CRINCR) */
2230 /* THE MEANING OF ARGUMENTS IS THE SAME AS MCRRQST */
2232 /* *** ATTENTION : */
2234 /* IERCOD=2 : CASE WHEN THE SYSTEM CANNOT FREE THE ALLOCATED MEMORY, */
2235 /* THE FOLLOWING MESSAGE APPEARS SYSTEMATICALLY ON CONSOLE ALPHA : */
2236 /* "THe system refuseS destruction of memory allocation" */
2238 /* IERCOD=3 CORRESPONDS TO THE CASE WHEN THE ARGUMENTS ARE NOT CORRECT */
2239 /* (THEY DO NOT ALLOW TO RECOGNIZE THE ALLOCATION IN THE TABLE)
2242 /* When the allocation is destroyed, the corresponding IOFSET is set to */
2243 /* 2 147 483 647. So, if one gets access to the table via IOFSET, there is */
2244 /* a trap. This allows to check that the freed memory zone is not usede. This verification is */
2245 /* valid only if the same sub-program uses and destroys the allocation. */
2248 /* ***********************************************************************
2251 /* COMMON OF PARAMETERS */
2253 /* COMMON OF STATISTICS */
2254 /* INCLUDE MCRGENE */
2256 /* ***********************************************************************
2261 /* TABLE OF MANAGEMENT OF DYNAMIC ALLOCATIONS IN MEMORY */
2265 /* SYSTEM, MEMORY, ALLOCATION */
2267 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2268 /* ----------------------------------- */
2272 /* ***********************************************************************
2274 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2275 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2276 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2277 /* 2 : UNIT OF ALLOCATION */
2278 /* 3 : NB OF ALLOCATED UNITS */
2279 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2281 /* 6 : STATIC ALLOCATION NUMBER */
2282 /* 7 : Required allocation size */
2283 /* 8 : address of the beginning of allocation */
2284 /* 9 : Size of the USER ZONE */
2285 /* 10 : ADDRESS of the START FLAG */
2286 /* 11 : ADDRESS of the END FLAG */
2287 /* 12 : Rank of creation of the allocation */
2289 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2290 /* NCORE : NB OF CURRENT ALLOCS */
2291 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2292 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2296 /* ----------------------------------------------------------------------*
2300 /* 20-10-86 : BF ; INITIAL VERSION */
2303 /* NRQST : NUMBER OF ALLOCATIONS */
2304 /* NDELT : NUMBER OF LIBERATIONS */
2305 /* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2306 /* MBYTE : MAX NUMBER OF OCTETS */
2311 /* SEARCH IN MCRGENE */
2316 for (i__ = mcrgene_.ncore - 1; i__ >= 0; --i__) {
2317 if (*iunit == mcrgene_.icore[i__].unit && *isize ==
2318 mcrgene_.icore[i__].reqsize && loc == mcrgene_.icore[i__].loc
2319 && *iofset == mcrgene_.icore[i__].offset) {
2327 /* IF THE ALLOCATION DOES NOT EXIST, LEAVE */
2333 /* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */
2335 ksys = mcrgene_.icore[n].alloctype;
2336 ibyte = mcrgene_.icore[n].size;
2337 iaddr = mcrgene_.icore[n].addr;
2338 iadfd = mcrgene_.icore[n].startaddr;
2339 iadff = mcrgene_.icore[n].endaddr;
2340 nrang = mcrgene_.icore[n].rank;
2342 /* Control of flags */
2349 if (ksys == static_allocation) {
2350 /* DE-ALLOCATION ON COMMON */
2352 mcrcomm_(&kop, &ibyte, &iaddr, &ier);
2357 /* DE-ALLOCATION SYSTEM */
2358 mcrfree_(&ibyte, reinterpret_cast<void**> (&iaddr), &ier);
2364 /* CALL ALLOWING TO CANCEL AUTOMATIC WATCH BY THE DEBUGGER */
2366 macrclw_(&iadfd, &iadff, &nrang);
2368 /* UPDATE OF STATISTICS */
2369 ++mcrstac_.ndelt[ksys];
2370 mcrstac_.nbyte[ksys] -= mcrgene_.icore[n].unit *
2371 mcrgene_.icore[n].reqsize;
2373 /* REMOVAL OF PARAMETERS IN MCRGENE */
2374 if (n < MAX_ALLOC_NB - 1) {
2375 noct = (mcrgene_.ncore - (n + 1)) * sizeof(mcrgene_.icore[0]);
2376 AdvApp2Var_SysBase::mcrfill_(&noct,
2377 &mcrgene_.icore[n + 1],
2378 &mcrgene_.icore[n]);
2382 /* *** Set to overflow of IOFSET */
2384 /* nested scope needed to avoid gcc compilation error crossing
2385 initialization with goto*/
2386 /* assign max positive integer to *iofset */
2387 const size_t shift = sizeof (*iofset) * 8 - 1;
2388 *iofset = (uintptr_t(1) << shift) - 1 /*2147483647 for 32bit*/;
2392 /* ----------------------------------------------------------------------*
2394 /* ERROR PROCESSING */
2397 /* REFUSE DE-ALLOCATION BY ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
2399 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2403 /* REFUSE DE-ALLOCATION BY THE SYSTEM */
2406 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2407 macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
2411 /* ALLOCATION DOES NOT EXIST */
2414 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2426 C*********************************************************************
2430 C Transfer a memory zone in another by managing intersections
2434 C MANIPULATION, MEMORY, TRANSFER, CHARACTER
2438 C nb_car : integer*4 number of characters to transfer.
2439 C source : source memory zone.
2441 C OUTPUT ARGUMENTS :
2442 C -------------------
2443 C dest : zone memory destination.
2448 C REFERENCES CALLED :
2449 C -------------------
2451 C DEMSCRIPTION/NOTES/LIMITATIONS :
2452 C -----------------------------------
2453 C Routine portable UNIX (SGI, ULTRIX, BULL)
2457 C**********************************************************************
2460 //=======================================================================
2461 //function : AdvApp2Var_SysBase::mcrfill_
2463 //=======================================================================
2464 int AdvApp2Var_SysBase::mcrfill_(integer *size,
2469 register char *jmin=static_cast<char*> (tin);
2470 register char *jmout=static_cast<char*> (tout);
2471 if (mcrfill_ABS(jmout-jmin) >= *size)
2472 memcpy( tout, tin, *size);
2473 else if (tin > tout)
2475 register integer n = *size;
2476 while (n-- > 0) *jmout++ = *jmin++;
2480 register integer n = *size;
2483 while (n-- > 0) *--jmout = *--jmin;
2489 /*........................................................................*/
2493 /* Routines for management of the dynamic memory. */
2495 /* Routine mcrfree */
2496 /* -------------- */
2498 /* Desallocation of a memory zone . */
2500 /* CALL MCRFREE (IBYTE,IADR,IER) */
2502 /* IBYTE INTEGER*4 : Nb of Octets to free */
2504 /* IADR POINTEUR : Start Address */
2506 /* IER INTEGER*4 : Return Code */
2509 /*........................................................................*/
2512 //=======================================================================
2513 //function : mcrfree_
2515 //=======================================================================
2516 int mcrfree_(integer *,//ibyte,
2522 Standard::Free(*iadr);
2523 //Standard::Free always nullifies address, so check becomes incorrect
2524 //if ( !*iadr ) *ier = 1;
2528 /*........................................................................*/
2532 /* Routines for management of the dynamic memory. */
2534 /* Routine mcrgetv */
2535 /* -------------- */
2537 /* Demand of memory allocation. */
2539 /* CALL MCRGETV(IBYTE,IADR,IER) */
2541 /* IBYTE (INTEGER*4) Nb of Bytes of allocation required */
2543 /* IADR (INTEGER*4) : Result. */
2545 /* IER (INTEGER*4) : Error Code : */
2548 /* = 1 ==> Allocation impossible */
2549 /* = -1 ==> Ofset > 2**31 - 1 */
2553 /*........................................................................*/
2555 //=======================================================================
2556 //function : mcrgetv_
2558 //=======================================================================
2559 int mcrgetv_(integer *sz,
2566 *iad = Standard::Allocate(*sz);
2567 if ( !*iad ) *ier = 1;
2572 //=======================================================================
2573 //function : mcrlist_
2575 //=======================================================================
2576 int AdvApp2Var_SysBase::mcrlist_(integer *ier) const
2579 /* System generated locals */
2582 /* Builtin functions */
2584 /* Local variables */
2587 integer ifmt, i__, nufmt, ntotal;
2591 /************************************************************************
2596 /* PRINT TABLE OF CURRENT DYNAMIC ALLOCATIONS */
2600 /* SYSTEM, ALLOCATION, MEMORY, LIST */
2602 /* INPUT ARGUMENTS : */
2603 /* ------------------ */
2606 /* OUTPUT ARGUMENTS : */
2607 /* ------------------- */
2610 /* IERCOD : ERROR CODE */
2612 /* IERCOD = 0 : OK */
2613 /* IERCOD > 0 : SERIOUS ERROR */
2614 /* IERCOD < 0 : WARNING */
2615 /* IERCOD = 1 : ERROR DESCRIPTION */
2616 /* IERCOD = 2 : ERROR DESCRIPTION */
2618 /* COMMONS USED : */
2619 /* ---------------- */
2621 /* MCRGENE VFORMT */
2623 /* REFERENCES CALLED : */
2624 /* ---------------------- */
2629 /* DESCRIPTION/NOTES/LIMITATIONS : */
2630 /* ----------------------------------- */
2636 /* ***********************************************************************
2639 /* INCLUDE MCRGENE */
2640 /* ***********************************************************************
2645 /* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2649 /* SYSTEM, MEMORY, ALLOCATION */
2651 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2652 /* ----------------------------------- */
2656 /* ***********************************************************************
2659 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2660 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2661 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2662 /* 2 : UNIT OF ALLOCATION */
2663 /* 3 : NB OF ALLOCATED UNITS */
2664 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2666 /* 6 : STATIC ALLOCATION NUMBER */
2667 /* 7 : Required allocation size */
2668 /* 8 : address of the beginning of allocation */
2669 /* 9 : Size of the USER ZONE */
2670 /* 10 : ADDRESS of the START FLAG */
2671 /* 11 : ADDRESS of the END FLAG */
2672 /* 12 : Rank of creation of the allocation */
2674 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2675 /* NCORE : NB OF CURRENT ALLOCS */
2676 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2677 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2681 /* ----------------------------------------------------------------------*
2685 /* ----------------------------------------------------------------------*
2689 //__s__copy(subrou, "MCRLIST", 7L, 7L);
2694 ifmt = mcrgene_.ncore;
2695 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2699 i__1 = mcrgene_.ncore;
2700 for (i__ = 0; i__ < i__1; ++i__) {
2702 ifmt = mcrgene_.icore[i__].unit * mcrgene_.icore[i__].reqsize
2704 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2711 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2717 //=======================================================================
2718 //function : mcrlocv_
2720 //=======================================================================
2721 int mcrlocv_(void* t,
2725 *l = reinterpret_cast<intptr_t> (t);
2729 //=======================================================================
2730 //function : AdvApp2Var_SysBase::mcrrqst_
2732 //=======================================================================
2733 int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
2743 /* Local variables */
2747 integer ksys , ibyte, irest, isyst, ier;
2748 intptr_t iadfd, iadff, iaddr,lofset, loc;
2752 /* **********************************************************************
2757 /* IMPLEMENTATION OF DYNAMIC MEMORY ALLOCATION */
2761 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
2763 /* INPUT ARGUMENTS : */
2764 /* ------------------ */
2765 /* IUNIT : NUMBER OF OCTET OF THE UNIT OF ALLOCATION */
2766 /* ISIZE : NUMBER OF UNITS REQUIRED */
2767 /* T : REFERENCE ADDRESS */
2769 /* OUTPUT ARGUMENTS : */
2770 /* ------------------- */
2771 /* IOFSET : OFFSET */
2772 /* IERCOD : ERROR CODE, */
2774 /* = 1 : MAX NB OF ALLOCS REACHED */
2775 /* = 2 : ARGUMENTS INCORRECT */
2776 /* = 3 : REFUSED DYNAMIC ALLOCATION */
2778 /* COMMONS USED : */
2779 /* ---------------- */
2780 /* MCRGENE, MCRSTAC */
2782 /* REFERENCES CALLED : */
2783 /* ----------------------- */
2784 /* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
2786 /* DESCRIPTION/NOTES/LIMITATIONS : */
2787 /* ----------------------------------- */
2790 /* -------------- */
2792 /* T IS THE ADDRESS OF A TABLE, IOFSET REPRESENTS THE DEPLACEMENT IN */
2793 /* UNITS OF IUNIT OCTETS BETWEEN THE ALLOCATED ZONE AND TABLE T */
2794 /* IERCOD=0 SIGNALS THAT THE ALLOCATION WORKS WELL, ANY OTHER */
2795 /* VALUE INDICATES A BUG. */
2798 /* LET THE DECLARATION REAL*4 T(1), SO IUNIT=4 . */
2799 /* CALL TO MCRRQST PORODUCES DYNAMIC ALLOCATION */
2800 /* AND GIVES VALUE TO VARIABLE IOFSET, */
2801 /* IF IT IS REQUIRED TO WRITE 1. IN THE 5TH ZONE REAL*4 */
2802 /* ALLOCATED IN THIS WAY, MAKE: */
2803 /* T(5+IOFSET)=1. */
2805 /* CASE OF ERRORS : */
2806 /* --------------- */
2808 /* IERCOD=1 : MAX NB OF ALLOCATION REACHED (ACTUALLY 200) */
2809 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2810 /* "The max number of memory allocation is reached : ,N" */
2812 /* IERCOD=2 : ARGUMENT IUNIT INCORRECT AS IT IS DIFFERENT FROM 1,2,4 OR 8 */
2813 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2814 /* "Unit OF allocation invalid : ,IUNIT" */
2816 /* IERCOD=3 : REFUSED DYNAMIC ALLOCATION (MORE PLACE IN MEMORY) */
2817 /* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2818 /* "The system refuses dynamic allocation of memory of N octets"
2820 /* with completev display of all allocations carried out till now */
2824 /* -------------- */
2826 /* MCRRQST MAKES DYNAMIC ALLOCATION OF VIRTUAL MEMORY ON THE BASE */
2827 /* OF ENTITIES OF 8 OCTETS (QUADWORDS), WHILE THE ALLOCATION IS REQUIRED BY */
2828 /* UNITS OF IUNIT OCTETS (1,2,4,8). */
2830 /* THE REQUIRED QUANTITY IS IUNIT*ISIZE OCTETS, THIS VALUE IS ROUNDED */
2831 /* SO THAT THE ALLOCATION WAS AN INTEGER NUMBER OF QUADWORDS. */
2836 /* ***********************************************************************
2839 /* COMMON OF PARAMETRES */
2840 /* COMMON OF INFORMATION ON STATISTICS */
2841 /* INCLUDE MCRGENE */
2843 /* ***********************************************************************
2847 /* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2851 /* SYSTEM, MEMORY, ALLOCATION */
2853 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2854 /* ----------------------------------- */
2858 /* ***********************************************************************
2861 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2862 /* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2863 /* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2864 /* 2 : UNIT OF ALLOCATION */
2865 /* 3 : NB OF ALLOCATED UNITS */
2866 /* 4 : REFERENCE ADDRESS OF THE TABLE */
2868 /* 6 : STATIC ALLOCATION NUMBER */
2869 /* 7 : Required allocation size */
2870 /* 8 : address of the beginning of allocation */
2871 /* 9 : Size of the USER ZONE */
2872 /* 10 : ADDRESS of the START FLAG */
2873 /* 11 : ADDRESS of the END FLAG */
2874 /* 12 : Rank of creation of the allocation */
2876 /* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2877 /* NCORE : NB OF CURRENT ALLOCS */
2878 /* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2879 /* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2884 /* ----------------------------------------------------------------------*
2886 /* 20-10-86 : BF ; INITIAL VERSION */
2889 /* NRQST : NUMBER OF ALLOCATIONS */
2890 /* NDELT : NUMBER OF LIBERATIONS */
2891 /* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2892 /* MBYTE : MAX NUMBER OF OCTETS */
2895 /* ----------------------------------------------------------------------*
2901 if (mcrgene_.ncore >= MAX_ALLOC_NB) {
2904 if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
2908 /* Calculate the size required by the user */
2909 ibyte = *iunit * *isize;
2911 /* Find the type of version (Phase of Production or Version Client) */
2914 /* Control allocated size in Production phase */
2920 //do__lio(&c__9, &c__1, "Require zero allocation", 26L);
2921 AdvApp2Var_SysBase::e__wsle();
2923 } else if (ibyte >= 4096000) {
2925 //do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L);
2926 //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
2927 AdvApp2Var_SysBase::e__wsle();
2933 /* CALCULATE THE SIZE OF THE USER ZONE (IZU) */
2934 /* . add size required by the user (IBYTE) */
2935 /* . add delta for alinement with the base */
2936 /* . round to multiple of 8 above */
2939 izu = ibyte + loc % *iunit;
2942 izu = izu + 8 - irest;
2945 /* CALCULATE THE SIZE REQUIRED FROM THE PRIMITIVE OF ALLOC */
2946 /* . add size of the user zone */
2947 /* . add 8 for alinement of start address of */
2948 /* allocation on multiple of 8 so that to be able to */
2949 /* set flags with Double Precision without other pb than alignement */
2950 /* . add 16 octets for two flags */
2954 /* DEMAND OF ALLOCATION */
2958 /* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
2959 /* ALLOCATION SUR TABLE */
2962 /* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
2963 /* IF ( IER .NE. 0 ) THEN */
2968 /* ALLOCATION SYSTEME */
2969 ksys = heap_allocation;
2970 mcrgetv_(&ibyte, reinterpret_cast<void**> (&iaddr), &ier);
2976 /* CALCULATE THE ADDRESSES OF FLAGS */
2978 iadfd = iaddr + 8 - iaddr % 8;
2979 iadff = iadfd + 8 + izu;
2981 /* CALCULATE USER OFFSET : */
2982 /* . difference between the user start address and the */
2984 /* . converts this difference in the user unit */
2986 lofset = iadfd + 8 + loc % *iunit - loc;
2987 *iofset = lofset / *iunit;
2989 /* If phase of production control flags */
2995 /* . the first flag is set by IADFD and the second by IADFF */
2996 /* . if phase of production, set to overflow the ZU */
2997 macrgfl_(&iadfd, &iadff, &iver, &izu);
2999 /* RANGING OF PARAMETERS IN MCRGENE */
3001 mcrgene_.icore[mcrgene_.ncore].prot = mcrgene_.lprot;
3002 mcrgene_.icore[mcrgene_.ncore].unit = (unsigned char)(*iunit);
3003 mcrgene_.icore[mcrgene_.ncore].reqsize = *isize;
3004 mcrgene_.icore[mcrgene_.ncore].loc = loc;
3005 mcrgene_.icore[mcrgene_.ncore].offset = *iofset;
3006 mcrgene_.icore[mcrgene_.ncore].alloctype = (unsigned char)ksys;
3007 mcrgene_.icore[mcrgene_.ncore].size = ibyte;
3008 mcrgene_.icore[mcrgene_.ncore].addr = iaddr;
3009 mcrgene_.icore[mcrgene_.ncore].userzone = mcrgene_.ncore;
3010 mcrgene_.icore[mcrgene_.ncore].startaddr = iadfd;
3011 mcrgene_.icore[mcrgene_.ncore].endaddr = iadff;
3012 mcrgene_.icore[mcrgene_.ncore].rank = mcrgene_.ncore + 1;
3017 /* CALL ALLOWING AUTOIMPLEMENTATION OF THE SET WATCH BY THE DEBUGGER */
3019 macrstw_(&iadfd, &iadff, &mcrgene_.ncore);
3023 ++mcrstac_.nrqst[ksys];
3024 mcrstac_.nbyte[ksys] += mcrgene_.icore[mcrgene_.ncore - 1].unit *
3025 mcrgene_.icore[mcrgene_.ncore - 1].reqsize;
3027 i__1 = mcrstac_.mbyte[ksys], i__2 = mcrstac_.nbyte[ksys];
3028 mcrstac_.mbyte[ksys] = advapp_max(i__1,i__2);
3032 /* ----------------------------------------------------------------------*
3034 /* ERROR PROCESSING */
3036 /* MAX NB OF ALLOC REACHED : */
3039 ifmt = MAX_ALLOC_NB;
3040 //__s__copy(subr, "MCRRQST", 7L, 7L);
3041 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3045 /* INCORRECT ARGUMENTS */
3049 //__s__copy(subr, "MCRRQST", 7L, 7L);
3050 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3053 /* SYSTEM REFUSES ALLOCATION */
3057 //__s__copy(subr, "MCRRQST", 7L, 7L);
3058 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3063 /* ----------------------------------------------------------------------*
3071 //=======================================================================
3072 //function : AdvApp2Var_SysBase::mgenmsg_
3074 //=======================================================================
3075 int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
3076 ftnlen )//nomprg_len)
3082 //=======================================================================
3083 //function : AdvApp2Var_SysBase::mgsomsg_
3085 //=======================================================================
3086 int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
3087 ftnlen )//nomprg_len)
3096 C*****************************************************************************
3098 C FUNCTION : CALL MIRAZ(LENGTH,ITAB)
3101 C RESET TO ZERO A TABLE OF LOGIC OR INTEGER.
3108 C ------------------
3109 C LENGTH : NUMBER OF OCTETS TO TRANSFER
3110 C ITAB : NAME OF THE TABLE
3112 C OUTPUT ARGUMENTS :
3113 C -------------------
3114 C ITAB : NAME OF THE TABLE SET TO ZERO
3119 C REFERENCES CALLED :
3120 C ---------------------
3122 C DEMSCRIPTION/NOTES/LIMITATIONS :
3123 C -----------------------------------
3128 C***********************************************************************
3130 //=======================================================================
3131 //function : AdvApp2Var_SysBase::miraz_
3133 //=======================================================================
3134 void AdvApp2Var_SysBase::miraz_(integer *taille,
3140 memset(adt , '\0' , *taille) ;
3142 //=======================================================================
3143 //function : AdvApp2Var_SysBase::mnfndeb_
3145 //=======================================================================
3146 integer AdvApp2Var_SysBase::mnfndeb_()
3153 //=======================================================================
3154 //function : AdvApp2Var_SysBase::mnfnimp_
3156 //=======================================================================
3157 integer AdvApp2Var_SysBase::mnfnimp_()
3164 //=======================================================================
3165 //function : AdvApp2Var_SysBase::msifill_
3167 //=======================================================================
3168 int AdvApp2Var_SysBase::msifill_(integer *nbintg,
3174 /* ***********************************************************************
3179 /* transfer Integer from one zone to another */
3183 /* TRANSFER , INTEGER , MEMORY */
3185 /* INPUT ARGUMENTS : */
3186 /* ------------------ */
3187 /* NBINTG : Nb of integers */
3188 /* IVECIN : Input vector */
3190 /* OUTPUT ARGUMENTS : */
3191 /* ------------------- */
3192 /* IVECOU : Output vector */
3194 /* COMMONS USED : */
3195 /* ---------------- */
3197 /* REFERENCES CALLED : */
3198 /* --------------------- */
3200 /* DESCRIPTION/NOTES/LIMITATIONS : */
3201 /* ----------------------------------- */
3204 /* ***********************************************************************
3207 /* ___ NOCTE : Number of octets to transfer */
3209 /* Parameter adjustments */
3214 nocte = *nbintg * sizeof(integer);
3215 AdvApp2Var_SysBase::mcrfill_(&nocte, &ivecin[1], &ivecou[1]);
3219 //=======================================================================
3220 //function : AdvApp2Var_SysBase::msrfill_
3222 //=======================================================================
3223 int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
3225 doublereal * vecsor)
3230 /* ***********************************************************************
3235 /* Transfer real from one zone to another */
3239 /* TRANSFER , REAL , MEMORY */
3241 /* INPUT ARGUMENTS : */
3242 /* ----------------- */
3243 /* NBREEL : Number of reals */
3244 /* VECENT : Input vector */
3246 /* OUTPUT ARGUMENTS : */
3247 /* ------------------- */
3248 /* VECSOR : Output vector */
3250 /* COMMONS USED : */
3251 /* ---------------- */
3253 /* REFERENCES CALLED : */
3254 /* ----------------------- */
3256 /* DESCRIPTION/NOTES/LIMITATIONS : */
3257 /* ----------------------------------- */
3260 /* ***********************************************************************
3263 /* ___ NOCTE : Nb of octets to transfer */
3265 /* Parameter adjustments */
3270 nocte = *nbreel * sizeof (doublereal);
3271 AdvApp2Var_SysBase::mcrfill_(&nocte, &vecent[1], &vecsor[1]);
3275 //=======================================================================
3276 //function : AdvApp2Var_SysBase::mswrdbg_
3278 //=======================================================================
3279 int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
3280 ftnlen )//ctexte_len)
3284 cilist io___1 = { 0, 0, 0, 0, 0 };
3287 /* ***********************************************************************
3292 /* Write message on console alpha if IBB>0 */
3296 /* MESSAGE, DEBUG */
3298 /* INPUT ARGUMENTS : */
3299 /* ----------------- */
3300 /* CTEXTE : Text to be written */
3302 /* OUTPUT ARGUMENTS : */
3303 /* ------------------- */
3306 /* COMMONS USED : */
3307 /* ---------------- */
3309 /* REFERENCES CALLED : */
3310 /* ----------------------- */
3312 /* DESCRIPTION/NOTES/LIMITATIONS : */
3313 /* ----------------------------------- */
3317 /* ***********************************************************************
3320 /* ***********************************************************************
3324 /* ***********************************************************************
3327 /* ***********************************************************************
3330 if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
3331 io___1.ciunit = AdvApp2Var_SysBase::mnfnimp_();
3333 //do__lio(&c__9, &c__1, "Dbg ", 4L);
3334 //do__lio(&c__9, &c__1, ctexte, ctexte_len);
3335 AdvApp2Var_SysBase::e__wsle();
3352 //=======================================================================
3353 //function : do__fio
3355 //=======================================================================
3356 int AdvApp2Var_SysBase::do__fio()
3360 //=======================================================================
3361 //function : do__lio
3363 //=======================================================================
3364 int AdvApp2Var_SysBase::do__lio ()
3368 //=======================================================================
3369 //function : e__wsfe
3371 //=======================================================================
3372 int AdvApp2Var_SysBase::e__wsfe ()
3376 //=======================================================================
3377 //function : e__wsle
3379 //=======================================================================
3380 int AdvApp2Var_SysBase::e__wsle ()
3384 //=======================================================================
3385 //function : s__wsfe
3387 //=======================================================================
3388 int AdvApp2Var_SysBase::s__wsfe ()
3392 //=======================================================================
3393 //function : s__wsle
3395 //=======================================================================
3396 int AdvApp2Var_SysBase::s__wsle ()
3403 C*****************************************************************************
3405 C FUNCTION : CALL MVRIRAZ(NBELT,DTAB)
3407 C Reset to zero a table with DOUBLE PRECISION
3414 C ------------------
3415 C NBELT : Number of elements of the table
3416 C DTAB : Table to initializer to zero
3418 C OUTPUT ARGUMENTS :
3419 C --------------------
3420 C DTAB : Table reset to zero
3425 C REFERENCES CALLED :
3426 C -----------------------
3428 C DEMSCRIPTION/NOTES/LIMITATIONS :
3429 C -----------------------------------
3433 C***********************************************************************
3435 //=======================================================================
3436 //function : AdvApp2Var_SysBase::mvriraz_
3438 //=======================================================================
3439 void AdvApp2Var_SysBase::mvriraz_(integer *taille,
3444 offset = *taille * 8 ;
3445 /* printf(" adt %d long %d\n",adt,offset); */
3446 memset(adt , '\0' , offset) ;