0022550: Fixing data races
[occt.git] / src / AdvApp2Var / AdvApp2Var_SysBase.cxx
... / ...
CommitLineData
1//
2// AdvApp2Var_SysBase.cxx
3//
4#include <math.h>
5#include <stdlib.h>
6#include <string.h>
7#include <AdvApp2Var_Data_f2c.hxx>
8#include <AdvApp2Var_SysBase.hxx>
9//
10#include <AdvApp2Var_Data.hxx>
11
12
13static
14int __i__len();
15
16static
17int __s__cmp();
18
19static
20int macrbrk_();
21
22static
23int macrchk_();
24
25static
26int macrclw_(long int *iadfld,
27 long int *iadflf,
28 integer *nalloc);
29static
30int macrerr_(long int *iad,
31 integer *nalloc);
32static
33int macrgfl_(long int *iadfld,
34 long int *iadflf,
35 integer *iphase,
36 integer *iznuti);
37static
38int macrmsg_(const char *crout,
39 integer *num,
40 integer *it,
41 doublereal *xt,
42 const char *ct,
43 ftnlen crout_len,
44 ftnlen ct_len);
45
46static
47int macrstw_(integer *iadfld,
48 integer *iadflf,
49 integer *nalloc);
50
51static
52int madbtbk_(integer *indice);
53
54static
55int magtlog_(const char *cnmlog,
56 const char *chaine,
57 integer *long__,
58 integer *iercod,
59 ftnlen cnmlog_len,
60 ftnlen chaine_len);
61
62
63static
64int mamdlng_(char *cmdlng,
65 ftnlen cmdlng_len);
66
67static
68int maostrb_();
69
70static
71int maostrd_();
72
73static
74int maoverf_(integer *nbentr,
75 doublereal *dtable);
76
77static
78int matrlog_(const char *cnmlog,
79 const char *chaine,
80 integer *length,
81 integer *iercod,
82 ftnlen cnmlog_len,
83 ftnlen chaine_len);
84
85static
86int matrsym_(const char *cnmsym,
87 const char *chaine,
88 integer *length,
89 integer *iercod,
90 ftnlen cnmsym_len,
91 ftnlen chaine_len);
92
93static
94int mcrcomm_(integer *kop,
95 integer *noct,
96 long int *iadr,
97 integer *ier);
98
99static
100int mcrfree_(integer *ibyte,
101 uinteger *iadr,
102 integer *ier);
103
104static
105int mcrgetv_(integer *sz,
106 uinteger *iad,
107 integer *ier);
108
109static
110int mcrlist_(integer *ier);
111
112static
113int mcrlocv_(long int t,
114 long int *l);
115
116
117/* Structures */
118static struct {
119 long int icore[12000];
120 integer ncore, lprot;
121} mcrgene_;
122
123static struct {
124 integer nrqst[2], ndelt[2], nbyte[2], mbyte[2];
125} mcrstac_;
126
127static struct {
128 integer lec, imp, keyb, mae, jscrn, itblt, ibb;
129} mblank__;
130
131#define mcrfill_ABS(a) (((a)<0)?(-(a)):(a))
132
133
134//=======================================================================
135//function : macinit_
136//purpose :
137//=======================================================================
138int AdvApp2Var_SysBase::macinit_(integer *imode,
139 integer *ival)
140
141{
142
143 /* Fortran I/O blocks */
144 static cilist io______1 = { 0, 0, 0, (char*) "(' --- Debug-mode : ',I10,' ---')", 0 };
145
146 /* ************************************************************************/
147 /* FUNCTION : */
148 /* ---------- */
149 /* INITIALIZATION OF READING WRITING UNITS AND 'IBB' */
150
151 /* KEYWORDS : */
152 /* ----------- */
153 /* MANAGEMENT, CONFIGURATION, UNITS, INITIALIZATION */
154
155 /* INPUT ARGUMENTS : */
156 /* -------------------- */
157 /* IMODE : MODE of INITIALIZATION :
158 0= DEFAULT, IMP IS 6, IBB 0 and LEC 5 */
159 /* 1= FORCE VALUE OF IMP */
160 /* 2= FORCE VALUE OF IBB */
161 /* 3= FORCE VALUE OF LEC */
162
163 /* ARGUMENT USED ONLY WHEN IMODE IS 1 OR 2 : */
164 /* IVAL : VALUE OF IMP WHEN IMODE IS 1 */
165 /* VALUE OF IBB WHEN IMODE IS 2 */
166 /* VALUE OF LEC WHEN IMODE IS 3 */
167 /* THERE IS NO CONTROL OF VALIDITY OF VALUE OF IVAL . */
168
169 /* OUTPUT ARGUMENTS : */
170 /* -------------------- */
171 /* NONE */
172
173 /* COMMONS USED : */
174 /* -------------- */
175 /* REFERENCES CALLED : */
176 /* ------------------- */
177 /* DESCRIPTION/NOTES/LIMITATIONS : */
178 /* ------------------------------- */
179
180 /* THIS IS ONLY INITIALIZATION OF THE COMMON BLANK FOR ALL */
181 /* MODULES THAT A PRIORI DO NOT NEED TO KNOW THE COMMONS OF T . */
182 /* WHEN A MODIFICATION OF IBB IS REQUIRED (IMODE=2) AN INFO MESSAGE */
183 /* IS SUBMITTED ON IMP, WITH THE NEW VALUE OF IBB. */
184
185 /* IBB : MODE DEBUG OF STRIM T : RULES OF USE : */
186 /* 0 RESTRAINED VERSION */
187 /* >0 THE GREATER IS IBB THE MORE COMMENTS THE VERSION HAS. */
188 /* FOR EXAMPLE FOR IBB=1 THE ROUTINES CALLED */
189 /* INFORM ON IMP ('INPUT IN TOTO', */
190 /* AND 'OUTPUT FROM TOTO'), AND THE ROUTINES THAT RETURN */
191 /* NON NULL ERROR CODE INFORM IT AS WELL. */
192 /* (BUT IT IS NOT TRUE FOR ALL ROUTINES OF T) */
193 /* > */
194 /* ***********************************************************************
195 */
196
197 if (*imode == 0) {
198 mblank__.imp = 6;
199 mblank__.ibb = 0;
200 mblank__.lec = 5;
201 } else if (*imode == 1) {
202 mblank__.imp = *ival;
203 } else if (*imode == 2) {
204 mblank__.ibb = *ival;
205 io______1.ciunit = mblank__.imp;
206 /*
207 s__wsfe(&io______1);
208 */
209 /*
210 do__fio(&c____1, (char *)&mblank__.ibb, (ftnlen)sizeof(integer));
211 */
212 AdvApp2Var_SysBase::e__wsfe();
213 } else if (*imode == 3) {
214 mblank__.lec = *ival;
215 }
216
217 /* ----------------------------------------------------------------------*
218 */
219
220 return 0;
221} /* macinit__ */
222
223//=======================================================================
224//function : macrai4_
225//purpose :
226//=======================================================================
227int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
228 integer *maxelm,
229 integer *itablo,
230 long int *iofset,
231 integer *iercod)
232
233{
234
235 /* ***********************************************************************
236 */
237
238 /* FUNCTION : */
239 /* ---------- */
240 /* Require dynamic allocation of type INTEGER */
241
242 /* KEYWORDS : */
243 /* ---------- */
244 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
245
246 /* INPUT ARGUMENTS : */
247 /* ----------------- */
248 /* NBELEM : Number of required units */
249 /* MAXELM : Max number of units available in ITABLO */
250 /* ITABLO : Reference Address of the rented zone */
251
252 /* OUTPUT ARGUMENTS : */
253 /* ------------------- */
254 /* IOFSET : Offset */
255 /* IERCOD : Error code */
256 /* = 0 : OK */
257 /* = 1 : Max nb of allocations attained */
258 /* = 2 : Incorrect arguments */
259 /* = 3 : Refused dynamic allocation */
260
261 /* COMMONS USED : */
262 /* ------------------ */
263
264 /* REFERENCES CALLED : */
265 /* --------------------- */
266 /* MCRRQST */
267
268 /* DESCRIPTION/NOTES/LIMITATIONS : */
269 /* ----------------------------------- */
270 /* (Cf description in the heading of MCRRQST) */
271
272 /* Table ITABLO should be dimensioned to MAXELM by the caller. */
273 /* If the request is lower or equal to MAXELM, IOFSET becomes = 0. */
274 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
275 /* > */
276 /* ***********************************************************************
277 */
278
279 integer iunit;
280 /* Parameter adjustments */
281 --itablo;
282
283
284 iunit = sizeof(integer);
285 /* Function Body */
286 if (*nbelem > *maxelm) {
287 AdvApp2Var_SysBase::mcrrqst_(&iunit, nbelem, (doublereal *)&itablo[1], iofset, iercod);
288 } else {
289 *iercod = 0;
290 *iofset = 0;
291 }
292 return 0 ;
293} /* macrai4_ */
294
295//=======================================================================
296//function : AdvApp2Var_SysBase::macrar8_
297//purpose :
298//=======================================================================
299int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
300 integer *maxelm,
301 doublereal *xtablo,
302 long int *iofset,
303 integer *iercod)
304
305{
306 static integer c__8 = 8;
307
308 /* ***********************************************************************
309 */
310
311 /* FUNCTION : */
312 /* ---------- */
313 /* Demand of dynamic allocation of type DOUBLE PRECISION */
314
315 /* KEYWORDS : */
316 /* ----------- */
317 /* SYSTEM, ALLOCATION, MEMORY, REALISATION */
318
319 /* INPUT ARGUMENTS : */
320 /* ------------------ */
321 /* NBELEM : Nb of units required */
322 /* MAXELM : Max Nb of units available in XTABLO */
323 /* XTABLO : Reference address of the rented zone */
324
325 /* OUTPUT ARGUMENTS : */
326 /* ------------------ */
327 /* IOFSET : Offset */
328 /* IERCOD : Error code */
329 /* = 0 : OK */
330 /* = 1 : Max Nb of allocations reached */
331 /* = 2 : Arguments incorrect */
332 /* = 3 : Refuse of dynamic allocation */
333
334 /* COMMONS USED : */
335 /* ------------------ */
336
337 /* REFERENCES CALLED : */
338 /* --------------------- */
339 /* MCRRQST */
340
341 /* DESCRIPTION/NOTES/LIMITATIONS : */
342 /* ----------------------------------- */
343 /* (Cf description in the heading of MCRRQST) */
344
345 /* Table XTABLO should be dimensioned to MAXELM by the caller. */
346 /* If the request is less or equal to MAXELM, IOFSET becomes = 0. */
347 /* Otherwise the demand of allocation is valid and IOFSET > 0. */
348
349 /* > */
350 /* ***********************************************************************
351 */
352
353
354 /* Parameter adjustments */
355 --xtablo;
356
357 /* Function Body */
358 if (*nbelem > *maxelm) {
359 AdvApp2Var_SysBase::mcrrqst_(&c__8, nbelem, &xtablo[1], iofset, iercod);
360 } else {
361 *iercod = 0;
362 *iofset = 0;
363 }
364 return 0 ;
365} /* macrar8_ */
366
367//=======================================================================
368//function : macrbrk_
369//purpose :
370//=======================================================================
371int macrbrk_()
372{
373 return 0 ;
374} /* macrbrk_ */
375
376//=======================================================================
377//function : macrchk_
378//purpose :
379//=======================================================================
380int macrchk_()
381{
382 /* System generated locals */
383 integer i__1;
384
385 /* Local variables */
386 static integer i__, j;
387 static long int ioff;
388 static doublereal t[1];
389 static integer loc;
390
391/* ***********************************************************************
392 */
393
394/* FUNCTION : */
395/* ---------- */
396/* CONTROL OF EXCESSES OF ALLOCATED MEMORY ZONE */
397
398/* KEYWORDS : */
399/* ----------- */
400/* SYSTEM, ALLOCATION, MEMORY, CONTROL, EXCESS */
401
402/* INPUT ARGUMENTS : */
403/* ----------------- */
404/* NONE */
405
406/* OUTPUT ARGUMENTS : */
407/* ------------------- */
408/* NONE */
409
410/* COMMONS USED : */
411/* ------------------ */
412/* MCRGENE */
413
414/* REFERENCES CALLED : */
415/* --------------------- */
416/* MACRERR, MAOSTRD */
417
418/* DESCRIPTION/NOTES/LIMITATIONS : */
419/* ----------------------------------- */
420
421/* > */
422/* ***********************************************************************
423 */
424
425/* ***********************************************************************
426 */
427
428/* FONCTION : */
429/* ---------- */
430/* TABLE OF MANAGEMENT OF DYNAMIC MEMOTY ALLOCATIONS */
431
432/* KEYWORDS : */
433/* ----------- */
434/* SYSTEM, MEMORY, ALLOCATION */
435
436/* DEMSCRIPTION/NOTES/LIMITATIONS : */
437/* ----------------------------------- */
438
439
440/* > */
441/* ***********************************************************************
442 */
443
444/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
445/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
446/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
447/* 2 : UNIT OF ALLOCATION */
448/* 3 : NB OF ALLOCATED UNITS */
449/* 4 : REFERENCE ADDRESS OF THE TABLE */
450/* 5 : IOFSET */
451/* 6 : STATIC ALLOCATION NUMBER */
452/* 7 : Required allocation size */
453/* 8 : address of the beginning of allocation */
454/* 9 : Size of the USER ZONE */
455/* 10 : ADDRESS of the START FLAG */
456/* 11 : ADDRESS of the END FLAG */
457/* 12 : Rank of creation of the allocation */
458
459/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
460/* NCORE : NB OF CURRENT ALLOCS */
461/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
462/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
463
464
465
466/* ----------------------------------------------------------------------*
467 */
468
469
470/* ----------------------------------------------------------------------*
471 */
472
473/* CALCULATE ADDRESS OF T */
474 mcrlocv_((long int)t, (long int *)&loc);
475
476 /* CONTROL OF FLAGS IN THE TABLE */
477 i__1 = mcrgene_.ncore;
478 for (i__ = 1; i__ <= i__1; ++i__) {
479
480 for (j = 10; j <= 11; ++j) {
481
482 if (mcrgene_.icore[j + i__ * 12 - 13] != -1) {
483
484 ioff = (mcrgene_.icore[j + i__ * 12 - 13] - loc) / 8;
485
486 if (t[ioff] != -134744073.) {
487
488 /* MSG : '*** ERREUR : REMOVAL FROM MEMORY OF ADDRESS
489 E:',ICORE(J,I) */
490 /* AND OF RANK ICORE(12,I) */
491 macrerr_((long int *)&mcrgene_.icore[j + i__ * 12 - 13],
492 (integer *)&mcrgene_.icore[i__ * 12 - 1]);
493
494 /* BACK-PARCING IN PHASE OF PRODUCTION */
495 maostrb_();
496
497 /* REMOVAL OF THE ADDRESS OF FLAG TO AVOID REMAKING ITS CONTROL */
498 mcrgene_.icore[j + i__ * 12 - 13] = -1;
499
500 }
501
502 }
503
504 /* L100: */
505 }
506
507 /* L1000: */
508 }
509 return 0 ;
510} /* macrchk_ */
511
512//=======================================================================
513//function : macrclw_
514//purpose :
515//=======================================================================
516int macrclw_(long int *,//iadfld,
517 long int *,//iadflf,
518 integer *)//nalloc)
519
520{
521 return 0 ;
522} /* macrclw_ */
523
524//=======================================================================
525//function : AdvApp2Var_SysBase::macrdi4_
526//purpose :
527//=======================================================================
528int AdvApp2Var_SysBase::macrdi4_(integer *nbelem,
529 integer *,//maxelm,
530 integer *itablo,
531 long int *iofset, /* Offset long (pmn) */
532 integer *iercod)
533
534{
535
536 /* ***********************************************************************
537 */
538
539/* FuNCTION : */
540/* ---------- */
541/* Destruction of dynamic allocation of type INTEGER */
542
543/* KEYWORDS : */
544/* ----------- */
545/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
546
547/* INPUT ARGUMENTS : */
548/* ------------------ */
549/* NBELEM : Nb of units required */
550/* MAXELM : Max Nb of units available in ITABLO */
551/* ITABLO : Reference Address of the allocated zone */
552/* IOFSET : Offset */
553
554/* OUTPUT ARGUMENTS : */
555/* --------------------- */
556/* IERCOD : Error Code */
557/* = 0 : OK */
558/* = 1 : Pb of de-allocation of a zone allocated in table */
559/* = 2 : The system refuses the demand of de-allocation */
560
561/* COMMONS USED : */
562/* ------------------ */
563
564/* REFERENCES CALLED : */
565/* --------------------- */
566/* MCRDELT */
567
568/* DESCRIPTION/NOTES/LIMITATIONS : */
569/* ----------------------------------- */
570/* (Cf description in the heading of MCRDELT) */
571/* > */
572/* ***********************************************************************
573 */
574 integer iunit;
575
576 /* Parameter adjustments */
577 --itablo;
578 iunit = sizeof(integer);
579 /* Function Body */
580 if (*iofset != 0) {
581 AdvApp2Var_SysBase::mcrdelt_(&iunit,
582 nbelem,
583 (doublereal *)&itablo[1],
584 iofset,
585 iercod);
586 } else {
587 *iercod = 0;
588 }
589 return 0 ;
590} /* macrdi4_ */
591
592//=======================================================================
593//function : AdvApp2Var_SysBase::macrdr8_
594//purpose :
595//=======================================================================
596int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
597 integer *,//maxelm,
598 doublereal *xtablo,
599 long int *iofset,
600 integer *iercod)
601
602{
603 static integer c__8 = 8;
604
605/* ***********************************************************************
606 */
607
608/* FUNCTION : */
609/* ---------- */
610/* Destruction of dynamic allocation of type DOUBLE PRECISION
611*/
612
613/* KEYWORDS : */
614/* ----------- */
615/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
616
617/* INPUT ARGUMENTS : */
618/* -------------------- */
619/* NBELEM : Nb of units required */
620/* MAXELM : Max nb of units available in XTABLO */
621/* XTABLO : Reference Address of the allocated zone */
622/* IOFSET : Offset */
623
624/* OUTPUT ARGUMENTS : */
625/* ------------------- */
626/* IERCOD : Error Code */
627/* = 0 : OK */
628/* = 1 : Pb of de-allocation of a zone allocated on table */
629/* = 2 : The system refuses the demand of de-allocation */
630
631/* COMMONS USED : */
632/* -------------- */
633
634/* REFERENCES CALLEDS : */
635/* -------------------- */
636/* MCRDELT */
637
638/* DESCRIPTION/NOTES/LIMITATIONS : */
639/* ----------------------------------- */
640/* (Cf description in the heading of MCRDELT) */
641
642/* > */
643/* ***********************************************************************
644 */
645
646
647 /* Parameter adjustments */
648 --xtablo;
649
650 /* Function Body */
651 if (*iofset != 0) {
652 AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, &xtablo[1], iofset, iercod);
653 } else {
654 *iercod = 0;
655 }
656 return 0 ;
657} /* macrdr8_ */
658
659//=======================================================================
660//function : macrerr_
661//purpose :
662//=======================================================================
663int macrerr_(long int *,//iad,
664 integer *)//nalloc)
665
666{
667 //static integer c__1 = 1;
668 /* Builtin functions */
669 //integer /*s__wsfe(),*/ /*do__fio(),*/ e__wsfe();
670
671 /* Fortran I/O blocks */
672 //static cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
673
674/* ***********************************************************************
675 */
676
677/* FUNCTION : */
678/* ---------- */
679/* WRITING OF ADDRESS REMOVED IN ALLOCS . */
680
681/* KEYWORDS : */
682/* ----------- */
683/* ALLOC CONTROL */
684
685/* INPUT ARGUMENTS : */
686/* ------------------ */
687/* IAD : ADDRESS TO INFORM OF REMOVAL */
688/* NALLOC : NUMBER OF ALLOCATION */
689
690/* OUTPUT ARGUMENTS : */
691/* --------------------- */
692/* NONE */
693
694/* COMMONS USED : */
695/* -------------- */
696
697/* REFERENCES CALLED : */
698/* ------------------- */
699
700/* DESCRIPTION/NOTES/LIMITATIONS : */
701/* ----------------------------------- */
702/* > */
703/* ***********************************************************************
704 */
705 /*
706 s__wsfe(&io___1);
707 */
708 /*
709 do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
710 do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
711 do__fio(&c__1, " sur l'allocation ", 18L);
712 do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
713 */
714 AdvApp2Var_SysBase::e__wsfe();
715
716 return 0 ;
717} /* macrerr_ */
718
719
720//=======================================================================
721//function : macrgfl_
722//purpose :
723//=======================================================================
724int macrgfl_(long int *iadfld,
725 long int *iadflf,
726 integer *iphase,
727 integer *iznuti)
728
729{
730 /* Initialized data */
731
732 static integer ifois = 0;
733
734 static char cbid[1];
735 static integer ibid, ienr;
736 static doublereal t[1];
737 static integer novfl;
738 static long int ioff,iadrfl, iadt;
739
740
741 /* ***********************************************************************
742 */
743
744 /* FUNCTION : */
745 /* ---------- */
746 /* IMPLEMENTATION OF TWO FLAGS START AND END OF THE ALLOCATED ZONE */
747 /* AND SETTING TO OVERFLOW OF THE USER SPACE IN PHASE OF PRODUCTION. */
748
749 /* KEYWORDS : */
750 /* ----------- */
751 /* ALLOCATION, CONTROL, EXCESS */
752
753 /* INPUT ARGUMENTS : */
754 /* ------------------ */
755 /* IADFLD : ADDRESS OF THE START FLAG */
756 /* IADFLF : ADDRESS OF THE END FLAG */
757 /* IPHASE : TYPE OF SOFTWARE VERSION : */
758 /* 0 = OFFICIAL VERSION */
759 /* 1 = PRODUCTION VERSION */
760 /* IZNUTI : SIZE OF THE USER ZONE IN OCTETS */
761
762 /* OUTPUT ARGUMENTS : */
763 /* ------------------ */
764 /* NONE */
765
766 /* COMMONS USED : */
767 /* ------------------ */
768
769 /* REFERENCES CALLED : */
770 /* ------------------- */
771 /* CRLOCT,MACRCHK */
772
773 /* DESCRIPTION/NOTES/LIMITATIONS : */
774 /* ------------------------------- */
775
776 /* > */
777 /* ***********************************************************************
778 */
779
780
781
782 /* ***********************************************************************
783 */
784
785 /* FUNCTION : */
786 /* ---------- */
787 /* TABLE FOR MANAGEMENT OF DYNAMIC ALLOCATIONS OF MEMORY */
788
789 /* KEYWORDS : */
790 /* ----------- */
791 /* SYSTEM, MEMORY, ALLOCATION */
792
793 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
794 /* ----------------------------------- */
795
796
797 /* > */
798 /* ***********************************************************************
799 */
800 /* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
801/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
802/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
803/* 2 : UNIT OF ALLOCATION */
804/* 3 : NB OF ALLOCATED UNITS */
805/* 4 : REFERENCE ADDRESS OF THE TABLE */
806/* 5 : IOFSET */
807/* 6 : STATIC ALLOCATION NUMBER */
808/* 7 : Required allocation size */
809/* 8 : address of the beginning of allocation */
810/* 9 : Size of the USER ZONE */
811/* 10 : ADDRESS of the START FLAG */
812/* 11 : ADDRESS of the END FLAG */
813/* 12 : Rank of creation of the allocation */
814
815/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
816/* NCORE : NB OF CURRENT ALLOCS */
817/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
818/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
819
820
821
822
823
824 /* ----------------------------------------------------------------------*
825 */
826
827
828 if (ifois == 0) {
829 matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
830 ifois = 1;
831 }
832
833 /* CALCULATE THE ADDRESS OF T */
834 mcrlocv_((long int)t, (long int *)&iadt);
835
836 /* CALCULATE THE OFFSET */
837 ioff = (*iadfld - iadt) / 8;
838
839 /* SET TO OVERFLOW OF THE USER ZONE IN CASE OF PRODUCTION VERSION */
840 if (*iphase == 1 && novfl == 0) {
841 ienr = *iznuti / 8;
842 maoverf_(&ienr, &t[ioff + 1]);
843 }
844
845 /* UPDATE THE START FLAG */
846 t[ioff] = -134744073.;
847
848 /* FAKE CALL TO STOP THE DEBUGGER : */
849 iadrfl = *iadfld;
850 macrbrk_();
851
852 /* UPDATE THE START FLAG */
853 ioff = (*iadflf - iadt) / 8;
854 t[ioff] = -134744073.;
855
856 /* FAKE CALL TO STOP THE DEBUGGER : */
857 iadrfl = *iadflf;
858 macrbrk_();
859
860 return 0 ;
861} /* macrgfl_ */
862
863//=======================================================================
864//function : macrmsg_
865//purpose :
866//=======================================================================
867int macrmsg_(const char *,//crout,
868 integer *,//num,
869 integer *it,
870 doublereal *xt,
871 const char *ct,
872 ftnlen ,//crout_len,
873 ftnlen ct_len)
874
875{
876
877 /* Local variables */
878 static integer inum, iunite;
879 static char cfm[80], cln[3];
880
881 /* Fortran I/O blocks */
882 static cilist io___5 = { 0, 0, 0, cfm, 0 };
883 static cilist io___6 = { 0, 0, 0, cfm, 0 };
884 static cilist io___7 = { 0, 0, 0, cfm, 0 };
885
886
887/* ***********************************************************************
888 */
889
890/* FUNCTION : */
891/* ---------- */
892/* MESSAGING OF ROUTINES OF ALLOCATION */
893
894/* KEYWORDS : */
895/* ----------- */
896/* ALLOC, MESSAGE */
897
898/* INPUT ARGUMENTSEE : */
899/* ------------------- */
900/* CROUT : NAME OF THE CALLING ROUTINE : MCRRQST, MCRDELT, MCRLIST
901*/
902/* ,CRINCR OR CRPROT */
903/* NUM : MESSAGE NUMBER */
904/* IT : TABLE OF INTEGER DATA */
905/* XT : TABLE OF REAL DATA */
906/* CT : ------------------ CHARACTER */
907
908/* OUTPUT ARGUMENTS : */
909/* --------------------- */
910/* NONE */
911
912/* COMMONS USED : */
913/* ------------------ */
914
915/* REFERENCES CALLED : */
916/* --------------------- */
917
918/* DESCRIPTION/NOTES/LIMITATIONS : */
919/* ----------------------------------- */
920
921/* ROUTINE FOR TEMPORARY USE, WAITING FOR THE 'NEW' MESSAGE */
922/* (STRIM 3.3 ?), TO MAKE THE ROUTINES OF ALLOC USABLE */
923/* IN STRIM T-M . */
924
925/* DEPENDING ON THE LANGUAGE, WRITING OF THE REQUIRED MESSAGE ON */
926/* UNIT IMP . */
927/* (REUSE OF SPECIFS OF VFORMA) */
928
929/* THE MESSAGE IS INITIALIZED AT 'MESSAGE MISSING', AND IT IS */
930/* REPLACED BY THE REQUIRED MESSAGE IF EXISTS. */
931/* > */
932/* ***********************************************************************
933 */
934
935/* LOCAL : */
936
937/* ----------------------------------------------------------------------*
938 */
939/* FIND MESSAGE DEPENDING ON THE LANGUAGE , THE ROUTINE */
940/* AND THE MESSAGE NUMBER */
941
942/* READING OF THE LANGUAGE : */
943 /* Parameter adjustments */
944 ct -= ct_len;
945 --xt;
946 --it;
947
948 /* Function Body */
949 mamdlng_(cln, 3L);
950
951/* INUM : TYPE OF MESSAGE : 0 AS TEXT, 1 1 INTEGER TO BE WRITTEN */
952/* -1 MESSAGE INEXISTING (1 INTEGER AND 1 CHAIN) */
953
954 inum = -1;
955/*
956 if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
957 __s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
958e de nom : ',A8)", 80L, 71L);
959 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
960 if (*num == 1) {
961 inum = 1;
962 __s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
963ee(s) : ',I6,/)", 80L, 62L);
964 } else if (*num == 2) {
965 inum = 1;
966 __s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
967 } else if (*num == 3) {
968 inum = 1;
969 __s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
970 }
971 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
972 if (*num == 1) {
973 inum = 0;
974 __s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
975e pas ')", 80L, 56L);
976 } else if (*num == 2) {
977 inum = 0;
978 __s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
979ion de memoire ')", 80L, 65L);
980 }
981 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
982 if (*num == 1) {
983 inum = 1;
984 __s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
985 atteint :',I6)", 80L, 62L);
986 } else if (*num == 2) {
987 inum = 1;
988 __s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
989 40L);
990 } else if (*num == 3) {
991 inum = 1;
992 __s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
993de ',I12,' octets')", 80L, 66L);
994 }
995 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
996 if (*num == 1) {
997 inum = 0;
998 __s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
999iste pas')", 80L, 57L);
1000 }
1001 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1002 if (*num == 1) {
1003 inum = 1;
1004 __s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
1005) : ',I12)", 80L, 57L);
1006 }
1007 }
1008
1009 } else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
1010 __s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
1011mm des Namens : ',A8)", 80L, 76L);
1012 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1013 if (*num == 1) {
1014 inum = 1;
1015 __s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
1016sung(en) : ',I6,/)", 80L, 65L);
1017 } else if (*num == 2) {
1018 inum = 1;
1019 __s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
1020 } else if (*num == 3) {
1021 inum = 1;
1022 __s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
1023 41L);
1024 }
1025 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1026 if (*num == 1) {
1027 inum = 0;
1028 __s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
1029 nicht !! ')", 80L, 59L);
1030 } else if (*num == 2) {
1031 inum = 0;
1032 __s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
1033Zuweisung !!')", 80L, 61L);
1034 }
1035 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1036 if (*num == 1) {
1037 inum = 1;
1038 __s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
1039icht :',I6)", 80L, 58L);
1040 } else if (*num == 2) {
1041 inum = 1;
1042 __s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
1043 ;
1044 } else if (*num == 3) {
1045 inum = 1;
1046 __s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
1047,I12,' Bytes')", 80L, 61L);
1048 }
1049 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1050 if (*num == 1) {
1051 inum = 0;
1052 __s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
1053stiert nicht !! ')", 80L, 65L);
1054 }
1055 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1056 if (*num == 1) {
1057 inum = 1;
1058 __s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
1059: ',I12)", 80L, 55L);
1060 }
1061 }
1062
1063 } else {
1064 __s__copy(cfm, "(' Message number ',I5,' is missing ' \
1065 ,'for program named: ',A8)", 80L, 93L);
1066 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1067 if (*num == 1) {
1068 inum = 1;
1069 __s__copy(cfm, "(/,' number of memory allocations carried out: \
1070',I6,/)", 80L, 54L);
1071 } else if (*num == 2) {
1072 inum = 1;
1073 __s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
1074 } else if (*num == 3) {
1075 inum = 1;
1076 __s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
1077 }
1078 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1079 if (*num == 1) {
1080 inum = 0;
1081 __s__copy(cfm, "(' Memory allocation to delete does not exist !\
1082! ')", 80L, 51L);
1083 } else if (*num == 2) {
1084 inum = 0;
1085 __s__copy(cfm, "(' System refuses deletion of memory allocation\
1086 !! ')", 80L, 53L);
1087 }
1088 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1089 if (*num == 1) {
1090 inum = 1;
1091 __s__copy(cfm, "(' max number of memory allocations reached :',\
1092I6)", 80L, 50L);
1093 } else if (*num == 2) {
1094 inum = 1;
1095 __s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
1096 40L);
1097 } else if (*num == 3) {
1098 inum = 1;
1099 __s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
1100' bytes ')", 80L, 57L);
1101 }
1102 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1103 if (*num == 1) {
1104 inum = 0;
1105 __s__copy(cfm, "(' Memory allocation to increment does not exis\
1106t !! ')", 80L, 54L);
1107 }
1108 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1109 if (*num == 1) {
1110 inum = 1;
1111 __s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
1112',I12)", 80L, 53L);
1113 }
1114 }
1115 }
1116 */
1117 /* ----------------------------------------------------------------------*
1118 */
1119 /* iMPLEMENTATION OF WRITE , WITH OR WITHOUT DATA : */
1120
1121 iunite = AdvApp2Var_SysBase::mnfnimp_();
1122 if (inum == 0) {
1123 io___5.ciunit = iunite;
1124 /*
1125 s__wsfe(&io___5);
1126 */
1127 AdvApp2Var_SysBase::e__wsfe();
1128 } else if (inum == 1) {
1129 io___6.ciunit = iunite;
1130 /*
1131 s__wsfe(&io___6);
1132 */
1133 /*
1134 do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
1135 */
1136 AdvApp2Var_SysBase::e__wsfe();
1137 } else {
1138 /* MESSAGE DOES NOT EXIST ... */
1139 io___7.ciunit = iunite;
1140 /*
1141 s__wsfe(&io___7);
1142 */
1143 /*
1144 do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
1145 do__fio(&c__1, crout, crout_len);
1146 */
1147 AdvApp2Var_SysBase::e__wsfe();
1148 }
1149
1150 return 0;
1151} /* macrmsg_ */
1152//=======================================================================
1153//function : macrstw_
1154//purpose :
1155//=======================================================================
1156int macrstw_(integer *,//iadfld,
1157 integer *,//iadflf,
1158 integer *)//nalloc)
1159
1160{
1161 return 0 ;
1162} /* macrstw_ */
1163
1164//=======================================================================
1165//function : madbtbk_
1166//purpose :
1167//=======================================================================
1168int madbtbk_(integer *indice)
1169{
1170 *indice = 0;
1171 return 0 ;
1172} /* madbtbk_ */
1173
1174//=======================================================================
1175//function : AdvApp2Var_SysBase::maermsg_
1176//purpose :
1177//=======================================================================
1178int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
1179 integer *,//icoder,
1180 ftnlen )//cnompg_len)
1181
1182{
1183 return 0 ;
1184} /* maermsg_ */
1185
1186//=======================================================================
1187//function : magtlog_
1188//purpose :
1189//=======================================================================
1190int magtlog_(const char *cnmlog,
1191 const char *,//chaine,
1192 integer *long__,
1193 integer *iercod,
1194 ftnlen cnmlog_len,
1195 ftnlen )//chaine_len)
1196
1197{
1198
1199 /* Local variables */
1200 static char cbid[255];
1201 static integer ibid, ier;
1202
1203
1204/* **********************************************************************
1205*/
1206
1207/* FUNCTION : */
1208/* ---------- */
1209/* RETURN TRANSLATION OF "NAME LOGIC STRIM" IN */
1210/* "INTERNAL SYNTAX" CORRESPONDING TO "PLACE OF RANKING" */
1211
1212/* KEYWORDS : */
1213/* ----------- */
1214/* NOM LOGIQUE STRIM , TRADUCTION */
1215
1216/* INPUT ARGUMENTS : */
1217/* ------------------ */
1218/* CNMLOG : NAME OF "NAME LOGIC STRIM" TO TRANSLATE */
1219
1220/* OUTPUT ARGUMENTS : */
1221/* ------------------- */
1222/* CHAINE : ADDRESS OF "PLACE OF RANKING" */
1223/* LONG : USEFUL LENGTH OF "PLACE OF RANKING" */
1224/* IERCOD : ERROR CODE */
1225/* IERCOD = 0 : OK */
1226/* IERCOD = 5 : PLACE OF RANKING CORRESPONDING TO INEXISTING LOGIC NAME */
1227
1228/* IERCOD = 6 : TRANSLATION TOO LONG FOR THE 'CHAIN' VARIABLE */
1229/* IERCOD = 7 : CRITICAL ERROR */
1230
1231/* COMMONS USED : */
1232/* ---------------- */
1233/* NONE */
1234
1235/* REFERENCES CALLED : */
1236/* --------------------- */
1237/* GNMLOG, MACHDIM */
1238
1239/* DESCRIPTION/NOTES/LIMITATIONS : */
1240/* ------------------------------- */
1241
1242/* SPECIFIC SGI ROUTINE */
1243
1244/* IN ALL CASES WHEN IERCOD IS >0, NO RESULT IS RETURNED*/
1245/* NOTION OF "USER SYNTAX' AND "INTERNAL SYNTAX" */
1246/* --------------------------------------------------- */
1247
1248/* THE "USER SYNTAX" IS THE SYNTAX WHERE THE USER*/
1249/* VISUALIZES OR INDICATES THE FILE OR DIRECTORY NAME */
1250/* DURING A SESSION OF STRIM100 */
1251
1252/* "INTERNAL SYNTAX" IS SYNTAX USED TO CARRY OUT */
1253/* OPERATIONS OF FILE PROCESSING INSIDE THE CODE */
1254/* (OPEN,INQUIRE,...ETC) */
1255
1256/* > */
1257/* ***********************************************************************
1258 */
1259/* DECLARATIONS */
1260/* ***********************************************************************
1261 */
1262
1263
1264/* ***********************************************************************
1265 */
1266/* PROCESSING */
1267/* ***********************************************************************
1268 */
1269
1270 *long__ = 0;
1271 *iercod = 0;
1272
1273 /* CONTROL OF EXISTENCE OF THE LOGIC NAME */
1274
1275 matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
1276 if (ier == 1) {
1277 goto L9500;
1278 }
1279 if (ier == 2) {
1280 goto L9700;
1281 }
1282
1283 /* CONTROL OF THE LENGTH OF CHAIN */
1284
1285 if (ibid > __i__len()/*chaine, chaine_len)*/) {
1286 goto L9600;
1287 }
1288
1289 //__s__copy(chaine, cbid, chaine_len, ibid);
1290 *long__ = ibid;
1291
1292 goto L9999;
1293
1294 /* ***********************************************************************
1295 */
1296 /* ERROR PROCESSING */
1297 /* ***********************************************************************
1298 */
1299
1300 L9500:
1301 *iercod = 5;
1302 //__s__copy(chaine, " ", chaine_len, 1L);
1303 goto L9999;
1304
1305 L9600:
1306 *iercod = 6;
1307 //__s__copy(chaine, " ", chaine_len, 1L);
1308 goto L9999;
1309
1310 L9700:
1311 *iercod = 7;
1312 //__s__copy(chaine, " ", chaine_len, 1L);
1313
1314 /* ***********************************************************************
1315 */
1316 /* RETURN TO THE CALLING PROGRAM */
1317 /* ***********************************************************************
1318 */
1319
1320 L9999:
1321 return 0;
1322} /* magtlog_ */
1323
1324//=======================================================================
1325//function : mainial_
1326//purpose :
1327//=======================================================================
1328int AdvApp2Var_SysBase::mainial_()
1329{
1330 mcrgene_.ncore = 0;
1331 return 0 ;
1332} /* mainial_ */
1333
1334//=======================================================================
1335//function : AdvApp2Var_SysBase::maitbr8_
1336//purpose :
1337//=======================================================================
1338int AdvApp2Var_SysBase::maitbr8_(integer *itaill,
1339 doublereal *xtab,
1340 doublereal *xval)
1341
1342{
1343 static integer c__504 = 504;
1344
1345 /* Initialized data */
1346
1347 static doublereal buff0[63] = {
1348 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1349 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1350 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1351 0.,0.,0.,0.,0.
1352 };
1353
1354 /* System generated locals */
1355 integer i__1;
1356
1357 /* Local variables */
1358 static integer i__;
1359 static doublereal buffx[63];
1360 static integer nbfois, noffst, nreste, nufois;
1361
1362/* ***********************************************************************
1363 */
1364
1365/* FUNCTION : */
1366/* ---------- */
1367/* INITIALIZATION TO A GIVEN VALUE OF A TABLE OF REAL *8 */
1368
1369/* KEYWORDS : */
1370/* ----------- */
1371/* MANIPULATIONS, MEMORY, INITIALIZATION, DOUBLE-PRECISION */
1372
1373/* INPUT ARGUMENTS : */
1374/* ----------------- */
1375/* ITAILL : SIZE OF THE TABLE */
1376/* XTAB : TABLE TO INITIALIZE WITH XVAL */
1377/* XVAL : VALUE TO SET IN XTAB(FROM 1 TO ITAILL) */
1378
1379/* OUTPUT ARGUMENTS : */
1380/* ------------------ */
1381/* XTAB : INITIALIZED TABLE */
1382
1383/* COMMONS USED : */
1384/* -------------- */
1385
1386/* REFERENCES CALLED : */
1387/* ------------------- */
1388
1389/* DESCRIPTION/NOTES/LIMITATIONS : */
1390/* ----------------------------------- */
1391
1392/* ONE CALLS MCRFILL WHICH MOVES BY PACKS OF 63 REALS */
1393
1394/* THE INITIAL PACK IS BUFF0 INITIATED BY DATA IF THE VALUE IS 0 */
1395/* OR OTHERWISE BUFFX INITIATED BY XVAL (LOOP). */
1396
1397
1398/* PORTABILITY : YES */
1399/* ACCESS : FREE */
1400
1401
1402/* > */
1403/* ***********************************************************************
1404 */
1405
1406
1407 /* Parameter adjustments */
1408 --xtab;
1409
1410 /* Function Body */
1411
1412 /* ----------------------------------------------------------------------*
1413 */
1414
1415 nbfois = *itaill / 63;
1416 noffst = nbfois * 63;
1417 nreste = *itaill - noffst;
1418
1419 if (*xval == 0.) {
1420 if (nbfois >= 1) {
1421 i__1 = nbfois;
1422 for (nufois = 1; nufois <= i__1; ++nufois) {
1423 AdvApp2Var_SysBase::mcrfill_(&c__504, (char *)buff0, (char *)&xtab[(nufois - 1) * 63 + 1]);
1424 /* L1000: */
1425 }
1426 }
1427
1428 if (nreste >= 1) {
1429 i__1 = nreste << 3;
1430 AdvApp2Var_SysBase::mcrfill_(&i__1, (char *)buff0, (char *)&xtab[noffst + 1]);
1431 }
1432 } else {
1433 for (i__ = 1; i__ <= 63; ++i__) {
1434 buffx[i__ - 1] = *xval;
1435 /* L2000: */
1436 }
1437 if (nbfois >= 1) {
1438 i__1 = nbfois;
1439 for (nufois = 1; nufois <= i__1; ++nufois) {
1440 AdvApp2Var_SysBase::mcrfill_(&c__504, (char *)buffx, (char *)&xtab[(nufois - 1) * 63 + 1]);
1441 /* L3000: */
1442 }
1443 }
1444
1445 if (nreste >= 1) {
1446 i__1 = nreste << 3;
1447 AdvApp2Var_SysBase::mcrfill_(&i__1, (char *)buffx, (char *)&xtab[noffst + 1]);
1448 }
1449 }
1450
1451 /* ----------------------------------------------------------------------*
1452 */
1453
1454 return 0;
1455} /* maitbr8_ */
1456
1457//=======================================================================
1458//function : mamdlng_
1459//purpose :
1460//=======================================================================
1461int mamdlng_(char *,//cmdlng,
1462 ftnlen )//cmdlng_len)
1463
1464{
1465
1466
1467/* ***********************************************************************
1468 */
1469
1470/* FUNCTION : */
1471/* ---------- */
1472/* RETURN THE CURRENT LANGUAGE */
1473
1474/* KEYWORDS : */
1475/* ----------- */
1476/* MANAGEMENT, CONFIGURATION, LANGUAGE, READING */
1477
1478/* INPUT ARGUMENTS : */
1479/* -------------------- */
1480/* CMDLNG : LANGUAGE */
1481
1482/* OUTPUT ARGUMENTS : */
1483/* ------------------- */
1484/* NONE */
1485
1486/* COMMONS USED : */
1487/* ------------------ */
1488/* MACETAT */
1489
1490/* REFERENCES CALLED : */
1491/* --------------------- */
1492/* NONE */
1493
1494/* DESCRIPTION/NOTES/LIMITATIONS : */
1495/* ----------------------------------- */
1496/* RIGHT OF USAGE : ANY APPLICATION */
1497
1498/* ATTENTION : THIS ROUTINE DEPENDS ON PRELIMINARY INITIALISATION */
1499/* ---------- WITH AMDGEN. */
1500/* SO IT IS ENOUGH TO PROVIDE THAT THIS INIT IS */
1501/* CORRECTLY IMPLEMENTED IN THE RESPECTIVE PROGRAMS */
1502/* > */
1503/* ***********************************************************************
1504 */
1505
1506
1507/* INCLUDE MACETAT */
1508/* < */
1509
1510/* ***********************************************************************
1511 */
1512
1513/* FUNCTION : */
1514/* ---------- */
1515/* CONTAINS INFORMATIONS ABOUT THE COMPOSITION OF */
1516/* THE EXECUTABLE AND ITS ENVIRONMENT : */
1517/* - LANGUAGES */
1518/* - PRESENT APPLICATIONS */
1519/* - AUTHORIZED TYPES OF ENTITIES (NON USED) */
1520/* AND INFORMATION DESCRIBING THE CURRENT STATE : */
1521/* - CURRENT APPLICATION */
1522/* - MODE OF USAGE (NOT USED) */
1523
1524/* KEYWORDS : */
1525/* ----------- */
1526/* APPLICATION, LANGUAGE */
1527
1528/* DEMSCRIPTION/NOTES/LIMITATIONS : */
1529/* ----------------------------------- */
1530
1531/* A) CHLANG*4 : LIST OF POSSIBLE VALUES OF THE LANGUAGE : */
1532/* 'FRA ','DEU ','ENG ' */
1533
1534/* CHL10N*4 : LIST OF POSSIBLE VALUES OF THE LOCALIZATION : */
1535/* 'FRA ','DEU ','ENG ', 'JIS ' */
1536
1537/* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : CURRENT, PREVIOUS AND NEXT APPLICATION
1538
1539/* C) CHMODE*4 : CURRENT MODE (NOT USED) */
1540
1541/* D) CHPRES*2 (1:NBRMOD) : LIST OF APPLICATIONS TAKEN INTO ACCOUNT */
1542
1543/* Rang ! Code interne ! Application */
1544/* ---------------------------------------------------------- */
1545/* 1 ! CD ! Modeling 2D */
1546/* 2 ! CA ! Modeling 2D by learning */
1547/* 3 ! CP ! Parameterized 2D modelization */
1548/* 4 ! PC ! Rheological 2D modelization */
1549/* 5 ! CU ! Milling 2 Axes 1/2 */
1550/* 6 ! CT ! Turning */
1551/* 7 ! TS ! 3D surface modeling */
1552/* 8 ! TV ! 3D volume modeling */
1553/* 9 ! MC ! Surface Meshing */
1554/* 10 ! MV ! Volume Meshing */
1555/* 11 ! TU ! Machining by 3 axes */
1556/* 12 ! T5 ! Machining by 3-5 axes */
1557/* 13 ! TR ! Machinning by 5 axes of regular surfaces */
1558/* 14 ! IG ! Interface IGES */
1559/* 15 ! ST ! Interface SET */
1560/* 16 ! VD ! Interface VDA */
1561/* 17 ! IM ! Interface of modeling */
1562/* 18 ! GA ! Generator APT/IFAPT */
1563/* 19 ! GC ! Generator COMPACT II */
1564/* 20 ! GP ! Generator PROMO */
1565/* 21 ! TN ! Machining by numerical copying */
1566/* 22 ! GM ! Management of models */
1567/* 23 ! GT ! Management of trace */
1568/* ---------------------------------------------------------- */
1569
1570
1571
1572/* > */
1573/* ***********************************************************************
1574 */
1575
1576/* NUMBER OF APPLICATIONS TAKEN INTO ACCOUNT */
1577
1578
1579/* NUMBER OF ENTITY TYPES MANAGED BY STRIM 100 */
1580 //__s__copy(cmdlng, macetat_.chlang, cmdlng_len, 4L);
1581
1582 return 0 ;
1583} /* mamdlng_ */
1584
1585//=======================================================================
1586//function : maostrb_
1587//purpose :
1588//=======================================================================
1589int maostrb_()
1590{
1591 return 0 ;
1592} /* maostrb_ */
1593
1594//=======================================================================
1595//function : maostrd_
1596//purpose :
1597//=======================================================================
1598int maostrd_()
1599{
1600 static integer imod;
1601
1602/* ***********************************************************************
1603 */
1604
1605/* FUNCTION : */
1606/* ---------- */
1607/* REFINE TRACE-BACK IN PRODUCTION PHASE */
1608
1609/* KEYWORDS : */
1610/* ----------- */
1611/* FUNCTION, SYSTEM, TRACE-BACK, REFINING, DEBUG */
1612
1613/* INPUT ARGUMENTS : */
1614/* ----------------- */
1615/* NONE */
1616
1617/* OUTPUT ARGUMENTS E : */
1618/* -------------------- */
1619/* NONE */
1620
1621/* COMMONS USED : */
1622/* -------------- */
1623/* NONE */
1624
1625/* REFERENCES CALLED : */
1626/* ------------------- */
1627/* MADBTBK */
1628
1629/* DESCRIPTION/NOTES/LIMITATIONS : */
1630/* ----------------------------------- */
1631/* THIS ROUTINE SHOULD BE CALLED TO REFINE */
1632/* TRACE-BACK IN PRODUCTION PHASE AND LEAVE TO TESTERS THE */
1633/* POSSIBILITY TO GET TRACE-BACK IN */
1634/* CLIENT VERSIONS IF ONE OF THE FOLLOWING CONDITIONS IS */
1635/* VERIFIED : */
1636/* - EXISTENCE OF SYMBOL 'STRMTRBK' */
1637/* - EXISTENCE OF FILE 'STRMINIT:STRMTRBK.DAT' */
1638
1639
1640/* > */
1641/* ***********************************************************************
1642 */
1643 madbtbk_(&imod);
1644 if (imod == 1) {
1645 maostrb_();
1646 }
1647 return 0 ;
1648} /* maostrd_ */
1649
1650//=======================================================================
1651//function : maoverf_
1652//purpose :
1653//=======================================================================
1654int maoverf_(integer *nbentr,
1655 doublereal *dtable)
1656
1657{
1658 /* Initialized data */
1659
1660 static integer ifois = 0;
1661
1662 /* System generated locals */
1663 integer i__1;
1664
1665 /* Local variables */
1666 static integer ibid;
1667 static doublereal buff[63];
1668 static integer ioct, indic, nrest, icompt;
1669
1670/* ***********************************************************************
1671 */
1672
1673/* FUNCTION : */
1674/* ---------- */
1675/* Initialisation in overflow of a tableau with DOUBLE PRECISION */
1676
1677/* KEYWORDS : */
1678/* ----------- */
1679/* MANIPULATION, MEMORY, INITIALISATION, OVERFLOW */
1680
1681/* INPUT ARGUMENTS : */
1682/* ----------------- */
1683/* NBENTR : Number of entries in the table */
1684
1685/* OUTPUT ARGUMENTS : */
1686/* ------------------ */
1687/* DATBLE : Table double precision initialized in overflow */
1688
1689/* COMMONS USED : */
1690/* ------------------ */
1691/* R8OVR contained in the include MAOVPAR.INC */
1692
1693/* REFERENCES CALLED : */
1694/* --------------------- */
1695/* MCRFILL */
1696
1697/* DESCRIPTION/NOTES/LIMITATIONS : */
1698/* ----------------------------------- */
1699/* 1) Doc. programmer : */
1700
1701/* This routine initialized to positive overflow a table with */
1702/* DOUBLE PRECISION. */
1703
1704/* Other types of tables (INTEGER*2, INTEGER, REAL, ...) */
1705/* are not managed by the routine. */
1706
1707/* It is usable in phase of developpement to detect the */
1708/* errors of initialization. */
1709
1710/* In official version, these calls will be inactive. */
1711
1712/* ACCESs : Agreed with AC. */
1713
1714/* The routine does not return error code. */
1715
1716/* Argument NBELEM should be positive. */
1717/* If it is negative or null, display message "MAOVERF : NBELEM = */
1718/* valeur_de_NBELEM" and a Trace Back by the call of routine MAOSTRB. */
1719
1720
1721/* 2) Doc. designer : */
1722
1723/* The idea is to minimize the number of calls */
1724/* to the routine of transfer of numeric zones, */
1725/* ---------- for the reason of performance. */
1726/* ! buffer ! For this a table of NLONGR
1727/* !__________! DOUBLE PRECISIONs is reserved. This buffer is initialized by */
1728/* <----------> the instruction DATA. The overflow is accessed in a */
1729/* NLONGR*8 specific COMMON not by a routine as */
1730/* the initialisation is done by DATA. */
1731
1732/* * If NBENTR<NLONGR, a part of the buffer is transfered*/
1733/* DTABLE in DTABLE. */
1734/* __________ */
1735/* ! amorce ! * Otherwise, the entire buffer is transfered in DTABLE. */
1736/* !__________! This initiates it. Then a loop is execute, which at each
1737*/
1738/* ! temps 1 ! iteration transfers the part of the already initialized table */
1739/* !__________! in the one that was not yet initialized. */
1740/* ! ! The size of the zone transfered by each call to MCRFILL
1741*/
1742/* ! temps 2 ! is NLONGR*2**(numero_de_l'iteration). When
1743*/
1744/* ! ! the size of the table to be initialized is */
1745/* !__________! less than the already initialized size, the loop is */
1746/* ! ! abandoned and thev last transfer is carried out to */
1747/* ! ! initialize the remaining table, except for the case when the size */
1748/* ! ! of the table is of type NLONGR*2**K. */
1749/* ! temps 3 ! */
1750/* ! ! * NLONGR will be equal to 19200. */
1751/* ! ! */
1752/* ! ! */
1753/* !__________! */
1754/* ! reste ! */
1755/* !__________! */
1756
1757
1758/* > */
1759/* ***********************************************************************
1760 */
1761
1762/* Inclusion of MAOVPAR.INC */
1763
1764/* CONSTANTS */
1765/* INCLUDE MAOVPAR */
1766/* ***********************************************************************
1767 */
1768
1769/* FUNCTION : */
1770/* ---------- */
1771/* DEFINES SPECIFIC LIMITED VALUES. */
1772
1773/* KEYWORDS : */
1774/* ----------- */
1775/* SYSTEM, LIMITS, VALUES, SPECIFIC */
1776
1777/* DEMSCRIPTION/NOTES/LIMITATIONS : */
1778/* ----------------------------------- */
1779/* *** THEY CAN'T BE REMOVED DURING EXECUTION. */
1780
1781/* *** THE VALUES OF UNDERFLOW AND OVERFLOW CAN'T BE */
1782/* DEFINED IN DECIMAL VALUES (ERROR OF COMPILATION D_FLOAT) */
1783/* THEY ARE DEFINED AS HEXADECIMAL VALUES */
1784
1785
1786/* > */
1787/* ***********************************************************************
1788 */
1789
1790
1791/* DECLARATION OF THE COMMON FOR NUMERIC TYPES */
1792
1793
1794/* DECLARATION OF THE COMMON FOR CHARACTER TYPES*/
1795
1796
1797
1798/* LOCAL VARIABLES */
1799
1800/* TABLES */
1801
1802/* DATAS */
1803 /* Parameter adjustments */
1804 --dtable;
1805
1806 /* Function Body */
1807
1808 /* vJMB R8OVR IS NOT YET initialized, so impossible to use DATA
1809 */
1810 /* DATA BUFF / NLONGR * R8OVR / */
1811
1812 /* init of BUFF is done only once */
1813
1814 if (ifois == 0) {
1815 for (icompt = 1; icompt <= 63; ++icompt) {
1816 buff[icompt - 1] = maovpar_.r8ovr;
1817 /* L20: */
1818 }
1819 ifois = 1;
1820 }
1821
1822 /* ^JMB */
1823 /* Exception */
1824 if (*nbentr < 63) {
1825 nrest = *nbentr << 3;
1826 AdvApp2Var_SysBase::mcrfill_(&nrest, (char *)buff, (char *)&dtable[1]);
1827 } else {
1828
1829 /* Start & initialization */
1830 ioct = 504;
1831 AdvApp2Var_SysBase::mcrfill_(&ioct, (char *)buff, (char *)&dtable[1]);
1832 indic = 63;
1833
1834 /* Loop. The upper limit is the integer value of the logarithm of base 2
1835 */
1836 /* of NBENTR/NLONGR. */
1837 i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.))
1838 ;
1839 for (ibid = 1; ibid <= i__1; ++ibid) {
1840
1841 AdvApp2Var_SysBase::mcrfill_(&ioct, (char *)&dtable[1], (char *)&dtable[indic + 1]);
1842 ioct += ioct;
1843 indic += indic;
1844
1845 /* L10: */
1846 }
1847
1848 nrest = ( *nbentr - indic ) << 3;
1849
1850 if (nrest > 0) {
1851 AdvApp2Var_SysBase::mcrfill_(&nrest, (char *)&dtable[1], (char *)&dtable[indic + 1]);
1852 }
1853
1854 }
1855 return 0 ;
1856} /* maoverf_ */
1857
1858//=======================================================================
1859//function : AdvApp2Var_SysBase::maovsr8_
1860//purpose :
1861//=======================================================================
1862int AdvApp2Var_SysBase::maovsr8_(integer *ivalcs)
1863{
1864 *ivalcs = maovpar_.r8ncs;
1865 return 0 ;
1866} /* maovsr8_ */
1867
1868//=======================================================================
1869//function : matrlog_
1870//purpose :
1871//=======================================================================
1872int matrlog_(const char *,//cnmlog,
1873 const char *,//chaine,
1874 integer *length,
1875 integer *iercod,
1876 ftnlen ,//cnmlog_len,
1877 ftnlen )//chaine_len)
1878
1879{
1880 *iercod = 1;
1881 *length = 0;
1882
1883 return 0 ;
1884} /* matrlog_ */
1885
1886//=======================================================================
1887//function : matrsym_
1888//purpose :
1889//=======================================================================
1890int matrsym_(const char *cnmsym,
1891 const char *,//chaine,
1892 integer *length,
1893 integer *iercod,
1894 ftnlen cnmsym_len,
1895 ftnlen )//chaine_len)
1896
1897{
1898 /* Local variables */
1899 static char chainx[255];
1900
1901/* ***********************************************************************
1902 */
1903
1904/* FUNCTION : */
1905/* ---------- */
1906/* RETURN THE VALUE OF A SYMBOL DEFINED DURING THE */
1907/* INITIALISATION OF A USER */
1908
1909/* KEYWORDS : */
1910/* ----------- */
1911/* TRANSLATION, SYMBOL */
1912
1913/* INPUT ARGUMENTS : */
1914/* -------------------- */
1915/* CNMSYM : NAME OF THE SYMBOL */
1916
1917/* OUTPUT ARGUMENTS : */
1918/* ------------------ */
1919/* CHAINE : TRANSLATION OF THE SYMBOL */
1920/* LENGTH : USEFUL LENGTH OF THE CHAIN */
1921/* IERCOD : ERROR CODE */
1922/* = 0 : OK */
1923/* = 1 : INEXISTING SYMBOL */
1924/* = 2 : OTHER ERROR */
1925
1926/* COMMONS USED : */
1927/* ------------------ */
1928/* NONE */
1929
1930/* REFERENCES CALLED : */
1931/* --------------------- */
1932/* LIB$GET_SYMBOL,MACHDIM */
1933
1934/* DESCRIPTION/NOTES/LIMITATIONS : */
1935/* ----------------------------------- */
1936/* - THIS ROUTINE IS VAX SPECIFIC */
1937/* - IN CASE OF ERROR (IERCOD>0), CHAIN = ' ' AND LENGTH = 0 */
1938/* - IF THE INPUT VARIABLE CNMSYM IS EMPTY, THE ROUTINE RETURNS IERCOD=1*/
1939/* > */
1940/* ***********************************************************************
1941 */
1942
1943
1944/* SGI...v */
1945
1946 /* SGI CALL MAGTLOG (CNMSYM,CHAINE,LENGTH,IERCOD) */
1947 magtlog_(cnmsym, chainx, length, iercod, cnmsym_len, 255L);
1948 /* SO...v */
1949 if (*iercod == 5) {
1950 *iercod = 1;
1951 }
1952 /* SO...^ */
1953 if (*iercod >= 2) {
1954 *iercod = 2;
1955 }
1956 //if (__s__cmp(chainx, "NONE", 255L, 4L) == 0) {
1957 if (__s__cmp() == 0) {
1958 //__s__copy(chainx, " ", 255L, 1L);
1959 *length = 0;
1960 }
1961 //__s__copy(chaine, chainx, chaine_len, 255L);
1962 /* SGI...^ */
1963
1964
1965 /* ***********************************************************************
1966 */
1967 /* ERROR PROCESSING */
1968 /* ***********************************************************************
1969 */
1970
1971
1972 /* L9999: */
1973 return 0;
1974} /* matrsym_ */
1975
1976//=======================================================================
1977//function : mcrcomm_
1978//purpose :
1979//=======================================================================
1980int mcrcomm_(integer *kop,
1981 integer *noct,
1982 long int *iadr,
1983 integer *ier)
1984
1985{
1986 /* Initialized data */
1987
1988 static integer ntab = 0;
1989
1990 /* System generated locals */
1991 integer i__1, i__2;
1992
1993 /* Local variables */
1994 static integer ideb;
1995 static doublereal dtab[32000];
1996 static long int itab[160] /* was [4][40] */;
1997 static integer ipre, i__, j, k;
1998
1999
2000/************************************************************************
2001*******/
2002
2003/* FUNCTION : */
2004/* ---------- */
2005/* DYNAMIC ALLOCATION ON COMMON */
2006
2007/* KEYWORDS : */
2008/* ----------- */
2009/* . ALLOCDYNAMIQUE, MEMORY, COMMON, ALLOC */
2010
2011/* INPUT ARGUMENTS : */
2012/* ------------------ */
2013/* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */
2014/* NOCT : NUMBER OF OCTETS */
2015
2016/* OUTPUT ARGUMENTS : */
2017/* ------------------- */
2018/* IADR : ADDRESS IN MEMORY OF THE FIRST OCTET */
2019/* * : */
2020/* * : */
2021/* IERCOD : ERROR CODE */
2022
2023/* IERCOD = 0 : OK */
2024/* IERCOD > 0 : CRITICAL ERROR */
2025/* IERCOD < 0 : WARNING */
2026/* IERCOD = 1 : ERROR DESCRIPTION */
2027/* IERCOD = 2 : ERROR DESCRIPTION */
2028
2029/* COMMONS USED : */
2030/* ---------------- */
2031
2032/* CRGEN2 */
2033
2034/* REFERENCES CALLED : */
2035/* ---------------------- */
2036
2037/* Type Name */
2038/* MCRLOCV */
2039
2040/* DESCRIPTION/NOTES/LIMITATIONS : */
2041/* ----------------------------------- */
2042
2043/* ATTENTION .... ITAB ARE NTAB NOT SAVED BETWEEN 2 CALLS..
2044*/
2045
2046/* > */
2047/* ***********************************************************************
2048 */
2049
2050/* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */
2051
2052/* ITAB : TABLE OF MANAGEMENT OF DTAB, ALLOCATED MEMORY ZONE . */
2053/* NTAB : NUMBER OF COMPLETED ALLOCATIONS. */
2054/* FORMAT OF ITAB : NUMBER OF ALLOCATED REAL*8, ADDRESS OF THE 1ST REAL*8
2055*/
2056/* , NOCT , VIRTUAL ADDRESS */
2057
2058/* PP COMMON / CRGEN2 / DTAB */
2059
2060
2061/* ----------------------------------------------------------------------*
2062 */
2063
2064 *ier = 0;
2065
2066 /* ALLOCATION : FIND A HOLE */
2067
2068 if (*kop == 1) {
2069 *iadr = 0;
2070 if (*noct < 1) {
2071 *ier = 1;
2072 goto L9900;
2073 }
2074 if (ntab >= 40) {
2075 *ier = 2;
2076 goto L9900;
2077 }
2078
2079 i__1 = ntab + 1;
2080 for (i__ = 1; i__ <= i__1; ++i__) {
2081 if (i__ <= 1) {
2082 ipre = 1;
2083 } else {
2084 ipre = itab[((i__ - 1) << 2) - 3] + itab[((i__ - 1) << 2) - 4];
2085 }
2086 if (i__ <= ntab) {
2087 ideb = itab[(i__ << 2) - 3];
2088 } else {
2089 ideb = 32001;
2090 }
2091 if ((ideb - ipre) << 3 >= *noct) {
2092 /* A HOLE WAS FOUND */
2093 i__2 = i__;
2094 for (j = ntab; j >= i__2; --j) {
2095 for (k = 1; k <= 4; ++k) {
2096 itab[k + ((j + 1) << 2) - 5] = itab[k + (j << 2) - 5];
2097 /* L1003: */
2098 }
2099 /* L1002: */
2100 }
2101 ++ntab;
2102 itab[(i__ << 2) - 4] = *noct / 8 + 1;
2103 itab[(i__ << 2) - 3] = ipre;
2104 itab[(i__ << 2) - 2] = *noct;
2105 mcrlocv_((long int)&dtab[ipre - 1], (long int *)iadr);
2106 itab[(i__ << 2) - 1] = *iadr;
2107 goto L9900;
2108 }
2109 /* L1001: */
2110 }
2111
2112 /* NO HOLE */
2113
2114 *ier = 3;
2115 goto L9900;
2116
2117 /* ----------------------------------- */
2118 /* DESTRUCTION OF THE ALLOCATION NUM : */
2119
2120 } else {
2121 i__1 = ntab;
2122 for (i__ = 1; i__ <= i__1; ++i__) {
2123 if (*noct != itab[(i__ << 2) - 2]) {
2124 goto L2001;
2125 }
2126 if (*iadr != itab[(i__ << 2) - 1]) {
2127 goto L2001;
2128 }
2129 /* THE ALLOCATION TO BE REMOVED WAS FOUND */
2130 i__2 = ntab;
2131 for (j = i__ + 1; j <= i__2; ++j) {
2132 for (k = 1; k <= 4; ++k) {
2133 itab[k + ((j - 1) << 2) - 5] = itab[k + (j << 2) - 5];
2134 /* L2003: */
2135 }
2136 /* L2002: */
2137 }
2138 --ntab;
2139 goto L9900;
2140 L2001:
2141 ;
2142 }
2143
2144 /* THE ALLOCATION DOES NOT EXIST */
2145
2146 *ier = 4;
2147 /* PP GOTO 9900 */
2148 }
2149
2150 L9900:
2151 return 0;
2152} /* mcrcomm_ */
2153
2154//=======================================================================
2155//function : AdvApp2Var_SysBase::mcrdelt_
2156//purpose :
2157//=======================================================================
2158int AdvApp2Var_SysBase::mcrdelt_(integer *iunit,
2159 integer *isize,
2160 doublereal *t,
2161 long int *iofset,
2162 integer *iercod)
2163
2164{
2165 static integer ibid;
2166 static doublereal xbid;
2167 static integer noct, iver, ksys, i__, n, nrang,
2168 ibyte, ier;
2169 static long int iadfd, iadff, iaddr, loc; /* Long adDresses*/
2170 static integer kop;
2171
2172/* ***********************************************************************
2173 */
2174
2175/* FUNCTION : */
2176/* ---------- */
2177/* DESTRUCTION OF A DYNAMIC ALLOCATION */
2178
2179/* KEYWORDS : */
2180/* ----------- */
2181/* SYSTEM, ALLOCATION, MEMORY, DESTRUCTION */
2182
2183/* INPUT ARGUMENTS : */
2184/* ------------------ */
2185/* IUNIT : NUMBER OF OCTETS OF THE ALLOCATION UNIT */
2186/* ISIZE : NUMBER OF UNITS REQUIRED */
2187/* T : REFERENCE ADDRESS */
2188/* IOFSET : OFFSET */
2189
2190/* OUTPUT ARGUMENTS : */
2191/* ------------------- */
2192/* IERCOD : ERROR CODE */
2193/* = 0 : OK */
2194/* = 1 : PB OF DE-ALLOCATION OF A ZONE ALLOCATED IN COMMON */
2195/* = 2 : THE SYSTEM REFUSES TO DEMAND DE-ALLOCATION */
2196/* = 3 : THE ALLOCATION TO BE DESTROYED DOES NOT EXIST. */
2197
2198/* COMMONS USED : */
2199/* ---------------- */
2200
2201
2202/* REFERENCES CALLED : */
2203/* --------------------- */
2204
2205
2206/* DESCRIPTION/NOTES/LIMITATIONS : */
2207/* ----------------------------------- */
2208
2209/* 1) UTILISATEUR */
2210/* ----------- */
2211
2212/* MCRDELT FREES ALLOCATED MEMORY ZONE */
2213/* BY ROUTINE MCRRQST (OR CRINCR) */
2214
2215/* THE MEANING OF ARGUMENTS IS THE SAME AS MCRRQST */
2216
2217/* *** ATTENTION : */
2218/* ----------- */
2219/* IERCOD=2 : CASE WHEN THE SYSTEM CANNOT FREE THE ALLOCATED MEMORY, */
2220/* THE FOLLOWING MESSAGE APPEARS SYSTEMATICALLY ON CONSOLE ALPHA : */
2221/* "THe system refuseS destruction of memory allocation" */
2222
2223/* IERCOD=3 CORRESPONDS TO THE CASE WHEN THE ARGUMENTS ARE NOT CORRECT */
2224/* (THEY DO NOT ALLOW TO RECOGNIZE THE ALLOCATION IN THE TABLE)
2225*/
2226
2227/* When the allocation is destroyed, the corresponding IOFSET is set to */
2228/* 2 147 483 647. So, if one gets access to the table via IOFSET, there is */
2229/* a trap. This allows to check that the freed memory zone is not usede. This verification is */
2230/* valid only if the same sub-program uses and destroys the allocation. */
2231
2232/* > */
2233/* ***********************************************************************
2234 */
2235
2236/* COMMON OF PARAMETERS */
2237
2238/* COMMON OF STATISTICS */
2239/* INCLUDE MCRGENE */
2240
2241/* ***********************************************************************
2242 */
2243
2244/* FUNCTION : */
2245/* ---------- */
2246/* TABLE OF MANAGEMENT OF DYNAMIC ALLOCATIONS IN MEMORY */
2247
2248/* KEYWORS : */
2249/* ----------- */
2250/* SYSTEM, MEMORY, ALLOCATION */
2251
2252/* DEMSCRIPTION/NOTES/LIMITATIONS : */
2253/* ----------------------------------- */
2254
2255
2256/* > */
2257/* ***********************************************************************
2258 */
2259/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2260/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2261/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2262/* 2 : UNIT OF ALLOCATION */
2263/* 3 : NB OF ALLOCATED UNITS */
2264/* 4 : REFERENCE ADDRESS OF THE TABLE */
2265/* 5 : IOFSET */
2266/* 6 : STATIC ALLOCATION NUMBER */
2267/* 7 : Required allocation size */
2268/* 8 : address of the beginning of allocation */
2269/* 9 : Size of the USER ZONE */
2270/* 10 : ADDRESS of the START FLAG */
2271/* 11 : ADDRESS of the END FLAG */
2272/* 12 : Rank of creation of the allocation */
2273
2274/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2275/* NCORE : NB OF CURRENT ALLOCS */
2276/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2277/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2278
2279
2280
2281/* ----------------------------------------------------------------------*
2282 */
2283
2284
2285/* 20-10-86 : BF ; INITIAL VERSION */
2286
2287
2288/* NRQST : NUMBER OF ALLOCATIONS */
2289/* NDELT : NUMBER OF LIBERATIONS */
2290/* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2291/* MBYTE : MAX NUMBER OF OCTETS */
2292
2293 /* Parameter adjustments */
2294 --t;
2295
2296 /* Function Body */
2297 *iercod = 0;
2298
2299/* SEARCH IN MCRGENE */
2300
2301 n = 0;
2302 mcrlocv_((long int)&t[1], (long int *)&loc);
2303
2304 for (i__ = mcrgene_.ncore; i__ >= 1; --i__) {
2305 if (*iunit == mcrgene_.icore[i__ * 12 - 11] && *isize ==
2306 mcrgene_.icore[i__ * 12 - 10] && loc == mcrgene_.icore[i__ *
2307 12 - 9] && *iofset == mcrgene_.icore[i__ * 12 - 8]) {
2308 n = i__;
2309 goto L1100;
2310 }
2311/* L1001: */
2312 }
2313L1100:
2314
2315/* IF THE ALLOCATION DOES NOT EXIST, LEAVE */
2316
2317 if (n <= 0) {
2318 goto L9003;
2319 }
2320
2321/* ALLOCATION RECOGNIZED : RETURN OTHER INFOS */
2322
2323 ksys = mcrgene_.icore[n * 12 - 7];
2324 ibyte = mcrgene_.icore[n * 12 - 6];
2325 iaddr = mcrgene_.icore[n * 12 - 5];
2326 iadfd = mcrgene_.icore[n * 12 - 3];
2327 iadff = mcrgene_.icore[n * 12 - 2];
2328 nrang = mcrgene_.icore[n * 12 - 1];
2329
2330/* Control of flags */
2331
2332 madbtbk_(&iver);
2333 if (iver == 1) {
2334 macrchk_();
2335 }
2336
2337 if (ksys <= 1) {
2338/* DE-ALLOCATION ON COMMON */
2339 kop = 2;
2340 mcrcomm_(&kop, &ibyte, &iaddr, &ier);
2341 if (ier != 0) {
2342 goto L9001;
2343 }
2344 } else {
2345/* DE-ALLOCATION SYSTEM */
2346 mcrfree_((integer *)&ibyte, (uinteger *)&iaddr, (integer *)&ier);
2347 if (ier != 0) {
2348 goto L9002;
2349 }
2350 }
2351
2352/* CALL ALLOWING TO CANCEL AUTOMATIC WATCH BY THE DEBUGGER */
2353
2354 macrclw_(&iadfd, &iadff, &nrang);
2355
2356/* UPDATE OF STATISTICS */
2357 if (ksys <= 1) {
2358 i__ = 1;
2359 } else {
2360 i__ = 2;
2361 }
2362 ++mcrstac_.ndelt[i__ - 1];
2363 mcrstac_.nbyte[i__ - 1] -= mcrgene_.icore[n * 12 - 11] *
2364 mcrgene_.icore[n * 12 - 10];
2365
2366/* REMOVAL OF PARAMETERS IN MCRGENE */
2367 if (n < 1000) {
2368/* noct = (mcrgene_1.ncore - n) * 48; */
2369 noct = (mcrgene_.ncore - n) * 12 * sizeof(long int);
2370 AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
2371 (char *)&mcrgene_.icore[(n + 1) * 12 - 12],
2372 (char *)&mcrgene_.icore[n * 12 - 12]);
2373 }
2374 --mcrgene_.ncore;
2375
2376/* *** Set to overflow of IOFSET */
2377 *iofset = 2147483647;
2378 goto L9900;
2379
2380/* ----------------------------------------------------------------------*
2381 */
2382/* ERROR PROCESSING */
2383
2384L9001:
2385/* REFUSE DE-ALLOCATION BY ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
2386 *iercod = 1;
2387 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2388 maostrd_();
2389 goto L9900;
2390
2391/* REFUSE DE-ALLOCATION BY THE SYSTEM */
2392L9002:
2393 *iercod = 2;
2394 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2395 macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
2396 maostrd_();
2397 goto L9900;
2398
2399/* ALLOCATION DOES NOT EXIST */
2400L9003:
2401 *iercod = 3;
2402 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2403 maostrd_();
2404 goto L9900;
2405
2406L9900:
2407
2408 return 0 ;
2409
2410} /* mcrdelt_ */
2411
2412
2413/*
2414C*********************************************************************
2415C
2416C FUNCTION :
2417C ----------
2418C Transfer a memory zone in another by managing intersections
2419C
2420C KEYWORDS :
2421C -----------
2422C MANIPULATION, MEMORY, TRANSFER, CHARACTER
2423C
2424C INPUT ARGUMENTS :
2425C -----------------
2426C nb_car : integer*4 number of characters to transfer.
2427C source : source memory zone.
2428C
2429C OUTPUT ARGUMENTS :
2430C -------------------
2431C dest : zone memory destination.
2432C
2433C COMMONS USED :
2434C ----------------
2435C
2436C REFERENCES CALLED :
2437C -------------------
2438C
2439C DEMSCRIPTION/NOTES/LIMITATIONS :
2440C -----------------------------------
2441C Routine portable UNIX (SGI, ULTRIX, BULL)
2442C
2443
2444C>
2445C**********************************************************************
2446*/
2447
2448//=======================================================================
2449//function : AdvApp2Var_SysBase::mcrfill_
2450//purpose :
2451//=======================================================================
2452int AdvApp2Var_SysBase::mcrfill_(integer *size,
2453 char *tin,
2454 char *tout)
2455
2456{
2457
2458 if (mcrfill_ABS(tout-tin) >= *size)
2459 memcpy( tout, tin, *size);
2460 else if (tin > tout)
2461 {
2462 register integer n = *size;
2463 register char *jmin=tin;
2464 register char *jmout=tout;
2465 while (n-- > 0) *jmout++ = *jmin++;
2466 }
2467 else
2468 {
2469 register integer n = *size;
2470 register char *jmin=tin+n;
2471 register char *jmout=tout+n;
2472 while (n-- > 0) *--jmout = *--jmin;
2473 }
2474 return 0;
2475}
2476
2477
2478/*........................................................................*/
2479/* */
2480/* FUNCTION : */
2481/* ---------- */
2482/* Routines for management of the dynamic memory. */
2483/* */
2484/* Routine mcrfree */
2485/* -------------- */
2486/* */
2487/* Desallocation of a memory zone . */
2488/* */
2489/* CALL MCRFREE (IBYTE,IADR,IER) */
2490/* */
2491/* IBYTE INTEGER*4 : Nb of Octets to free */
2492/* */
2493/* IADR POINTEUR : Start Address */
2494/* */
2495/* IER INTEGER*4 : Return Code */
2496/* */
2497/* */
2498/*........................................................................*/
2499/* */
2500
2501//=======================================================================
2502//function : mcrfree_
2503//purpose :
2504//=======================================================================
2505int mcrfree_(integer *,//ibyte,
2506 uinteger *iadr,
2507 integer *ier)
2508
2509{
2510 *ier=0;
2511 free((void*)*iadr);
2512 if ( !*iadr ) *ier = 1;
2513 return 0;
2514}
2515
2516/*........................................................................*/
2517/* */
2518/* FONCTION : */
2519/* ---------- */
2520/* Routines for management of the dynamic memory. */
2521/* */
2522/* Routine mcrgetv */
2523/* -------------- */
2524/* */
2525/* Demand of memory allocation. */
2526/* */
2527/* CALL MCRGETV(IBYTE,IADR,IER) */
2528/* */
2529/* IBYTE (INTEGER*4) Nb of Bytes of allocation required */
2530/* */
2531/* IADR (INTEGER*4) : Result. */
2532/* */
2533/* IER (INTEGER*4) : Error Code : */
2534/* */
2535/* = 0 ==> OK */
2536/* = 1 ==> Allocation impossible */
2537/* = -1 ==> Ofset > 2**31 - 1 */
2538/* */
2539
2540/* */
2541/*........................................................................*/
2542
2543//=======================================================================
2544//function : mcrgetv_
2545//purpose :
2546//=======================================================================
2547int mcrgetv_(integer *sz,
2548 uinteger *iad,
2549 integer *ier)
2550
2551{
2552
2553 *ier = 0;
2554 *iad = (uinteger)malloc(*sz);
2555 if ( !*iad ) *ier = 1;
2556 return 0;
2557}
2558
2559
2560//=======================================================================
2561//function : mcrlist_
2562//purpose :
2563//=======================================================================
2564int mcrlist_(integer *ier)
2565
2566{
2567 /* System generated locals */
2568 integer i__1;
2569
2570 /* Builtin functions */
2571
2572 /* Local variables */
2573 static char cfmt[1];
2574 static doublereal dfmt;
2575 static integer ifmt, i__, nufmt, ntotal;
2576 static char subrou[7];
2577
2578
2579/************************************************************************
2580*******/
2581
2582/* FUNCTION : */
2583/* ---------- */
2584/* PRINT TABLE OF CURRENT DYNAMIC ALLOCATIONS */
2585
2586/* KEYWORDS : */
2587/* ----------- */
2588/* SYSTEM, ALLOCATION, MEMORY, LIST */
2589
2590/* INPUT ARGUMENTS : */
2591/* ------------------ */
2592/* . NONE */
2593
2594/* OUTPUT ARGUMENTS : */
2595/* ------------------- */
2596/* * : */
2597/* * : */
2598/* IERCOD : ERROR CODE */
2599
2600/* IERCOD = 0 : OK */
2601/* IERCOD > 0 : SERIOUS ERROR */
2602/* IERCOD < 0 : WARNING */
2603/* IERCOD = 1 : ERROR DESCRIPTION */
2604/* IERCOD = 2 : ERROR DESCRIPTION */
2605
2606/* COMMONS USED : */
2607/* ---------------- */
2608
2609/* MCRGENE VFORMT */
2610
2611/* REFERENCES CALLED : */
2612/* ---------------------- */
2613
2614/* Type Name */
2615/* VFORMA */
2616
2617/* DESCRIPTION/NOTES/LIMITATIONS : */
2618/* ----------------------------------- */
2619/* . NONE */
2620
2621
2622
2623/* > */
2624/* ***********************************************************************
2625 */
2626
2627/* INCLUDE MCRGENE */
2628/* ***********************************************************************
2629 */
2630
2631/* FUNCTION : */
2632/* ---------- */
2633/* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2634
2635/* KEYWORDS : */
2636/* ----------- */
2637/* SYSTEM, MEMORY, ALLOCATION */
2638
2639/* DEMSCRIPTION/NOTES/LIMITATIONS : */
2640/* ----------------------------------- */
2641
2642
2643/* > */
2644/* ***********************************************************************
2645 */
2646
2647/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2648/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2649/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2650/* 2 : UNIT OF ALLOCATION */
2651/* 3 : NB OF ALLOCATED UNITS */
2652/* 4 : REFERENCE ADDRESS OF THE TABLE */
2653/* 5 : IOFSET */
2654/* 6 : STATIC ALLOCATION NUMBER */
2655/* 7 : Required allocation size */
2656/* 8 : address of the beginning of allocation */
2657/* 9 : Size of the USER ZONE */
2658/* 10 : ADDRESS of the START FLAG */
2659/* 11 : ADDRESS of the END FLAG */
2660/* 12 : Rank of creation of the allocation */
2661
2662/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2663/* NCORE : NB OF CURRENT ALLOCS */
2664/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2665/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2666
2667
2668
2669/* ----------------------------------------------------------------------*
2670 */
2671
2672
2673/* ----------------------------------------------------------------------*
2674 */
2675
2676 *ier = 0;
2677 //__s__copy(subrou, "MCRLIST", 7L, 7L);
2678
2679/* WRITE HEADING */
2680
2681 nufmt = 1;
2682 ifmt = mcrgene_.ncore;
2683 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2684
2685 ntotal = 0;
2686
2687 i__1 = mcrgene_.ncore;
2688 for (i__ = 1; i__ <= i__1; ++i__) {
2689 nufmt = 2;
2690 ifmt = mcrgene_.icore[i__ * 12 - 11] * mcrgene_.icore[i__ * 12 - 10]
2691 ;
2692 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2693 ntotal += ifmt;
2694/* L1001: */
2695 }
2696
2697 nufmt = 3;
2698 ifmt = ntotal;
2699 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2700
2701 return 0 ;
2702} /* mcrlist_ */
2703
2704
2705//=======================================================================
2706//function : mcrlocv_
2707//purpose :
2708//=======================================================================
2709int mcrlocv_(long int t,
2710 long int *l)
2711
2712{
2713 *l = t;
2714 return 0 ;
2715}
2716
2717//=======================================================================
2718//function : AdvApp2Var_SysBase::mcrrqst_
2719//purpose :
2720//=======================================================================
2721int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
2722 integer *isize,
2723 doublereal *t,
2724 long int *iofset,
2725 integer *iercod)
2726
2727{
2728
2729 integer i__1, i__2;
2730
2731 /* Local variables */
2732 static doublereal dfmt;
2733 static integer ifmt, iver;
2734 static char subr[7];
2735 static integer ksys , ibyte, irest, isyst, ier;
2736 static long int iadfd, iadff, iaddr,lofset, loc;
2737 static integer izu;
2738
2739
2740/* **********************************************************************
2741*/
2742
2743/* FUNCTION : */
2744/* ---------- */
2745/* IMPLEMENTATION OF DYNAMIC MEMORY ALLOCATION */
2746
2747/* KEYWORDS : */
2748/* ----------- */
2749/* SYSTEM, ALLOCATION, MEMORY, REALISATION */
2750
2751/* INPUT ARGUMENTS : */
2752/* ------------------ */
2753/* IUNIT : NUMBER OF OCTET OF THE UNIT OF ALLOCATION */
2754/* ISIZE : NUMBER OF UNITS REQUIRED */
2755/* T : REFERENCE ADDRESS */
2756
2757/* OUTPUT ARGUMENTS : */
2758/* ------------------- */
2759/* IOFSET : OFFSET */
2760/* IERCOD : ERROR CODE, */
2761/* = 0 : OK */
2762/* = 1 : MAX NB OF ALLOCS REACHED */
2763/* = 2 : ARGUMENTS INCORRECT */
2764/* = 3 : REFUSED DYNAMIC ALLOCATION */
2765
2766/* COMMONS USED : */
2767/* ---------------- */
2768/* MCRGENE, MCRSTAC */
2769
2770/* REFERENCES CALLED : */
2771/* ----------------------- */
2772/* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
2773
2774/* DESCRIPTION/NOTES/LIMITATIONS : */
2775/* ----------------------------------- */
2776
2777/* 1) USER */
2778/* -------------- */
2779
2780/* T IS THE ADDRESS OF A TABLE, IOFSET REPRESENTS THE DEPLACEMENT IN */
2781/* UNITS OF IUNIT OCTETS BETWEEN THE ALLOCATED ZONE AND TABLE T */
2782/* IERCOD=0 SIGNALS THAT THE ALLOCATION WORKS WELL, ANY OTHER */
2783/* VALUE INDICATES A BUG. */
2784
2785/* EXAMPLE : */
2786/* LET THE DECLARATION REAL*4 T(1), SO IUNIT=4 . */
2787/* CALL TO MCRRQST PORODUCES DYNAMIC ALLOCATION */
2788/* AND GIVES VALUE TO VARIABLE IOFSET, */
2789/* IF IT IS REQUIRED TO WRITE 1. IN THE 5TH ZONE REAL*4 */
2790/* ALLOCATED IN THIS WAY, MAKE: */
2791/* T(5+IOFSET)=1. */
2792
2793/* CASE OF ERRORS : */
2794/* --------------- */
2795
2796/* IERCOD=1 : MAX NB OF ALLOCATION REACHED (ACTUALLY 200) */
2797/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2798/* "The max number of memory allocation is reached : ,N" */
2799
2800/* IERCOD=2 : ARGUMENT IUNIT INCORRECT AS IT IS DIFFERENT FROM 1,2,4 OR 8 */
2801/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2802/* "Unit OF allocation invalid : ,IUNIT" */
2803
2804/* IERCOD=3 : REFUSED DYNAMIC ALLOCATION (MORE PLACE IN MEMORY) */
2805/* AND THE FOLLOWING MESSAGE APPEARS IN THE CONSOLE ALPHA : */
2806/* "The system refuses dynamic allocation of memory of N octets"
2807*/
2808/* with completev display of all allocations carried out till now */
2809
2810
2811/* 2) DESIGNER */
2812/* -------------- */
2813
2814/* MCRRQST MAKES DYNAMIC ALLOCATION OF VIRTUAL MEMORY ON THE BASE */
2815/* OF ENTITIES OF 8 OCTETS (QUADWORDS), WHILE THE ALLOCATION IS REQUIRED BY */
2816/* UNITS OF IUNIT OCTETS (1,2,4,8). */
2817
2818/* THE REQUIRED QUANTITY IS IUNIT*ISIZE OCTETS, THIS VALUE IS ROUNDED */
2819/* SO THAT THE ALLOCATION WAS AN INTEGER NUMBER OF QUADWORDS. */
2820
2821
2822
2823/* > */
2824/* ***********************************************************************
2825 */
2826
2827/* COMMON OF PARAMETRES */
2828/* COMMON OF INFORMATION ON STATISTICS */
2829/* INCLUDE MCRGENE */
2830
2831/* ***********************************************************************
2832 */
2833/* FUNCTION : */
2834/* ---------- */
2835/* TABLE FOR MANAGEMENT OF DYNAMIC MEMORY ALLOCATIONS */
2836
2837/* KEYWORDS : */
2838/* ----------- */
2839/* SYSTEM, MEMORY, ALLOCATION */
2840
2841/* DEMSCRIPTION/NOTES/LIMITATIONS : */
2842/* ----------------------------------- */
2843
2844
2845/* > */
2846/* ***********************************************************************
2847 */
2848
2849/* ICORE : TABLE OF EXISTING ALLOCATIONS, EACH HAVING : */
2850/* 1 : LEVEL OF PROTECTION (0=NOT PROTECTED, OTHER=PROTECTED) */
2851/* (PROTECTED MEANS NOT DESTROYED BY CRRSET .) */
2852/* 2 : UNIT OF ALLOCATION */
2853/* 3 : NB OF ALLOCATED UNITS */
2854/* 4 : REFERENCE ADDRESS OF THE TABLE */
2855/* 5 : IOFSET */
2856/* 6 : STATIC ALLOCATION NUMBER */
2857/* 7 : Required allocation size */
2858/* 8 : address of the beginning of allocation */
2859/* 9 : Size of the USER ZONE */
2860/* 10 : ADDRESS of the START FLAG */
2861/* 11 : ADDRESS of the END FLAG */
2862/* 12 : Rank of creation of the allocation */
2863
2864/* NDIMCR : NB OF DATA OF EACH ALLOC IN ICORE */
2865/* NCORE : NB OF CURRENT ALLOCS */
2866/* LPROT : COMMUNICATION BETWEEN CRPROT AND MCRRQST, SET TO 0 BY MCRRQST */
2867/* FLAG : VALUE OF THE FLAG USED FOR EXCESSES */
2868
2869
2870
2871
2872/* ----------------------------------------------------------------------*
2873 */
2874/* 20-10-86 : BF ; INITIAL VERSION */
2875
2876
2877/* NRQST : NUMBER OF ALLOCATIONS */
2878/* NDELT : NUMBER OF LIBERATIONS */
2879/* NBYTE : TOTAL NUMBER OF OCTETS OF ALLOCATIONS */
2880/* MBYTE : MAX NUMBER OF OCTETS */
2881
2882
2883/* ----------------------------------------------------------------------*
2884 */
2885
2886 /* Parameter adjustments */
2887 --t;
2888
2889 /* Function Body */
2890 *iercod = 0;
2891
2892 if (mcrgene_.ncore >= 1000) {
2893 goto L9001;
2894 }
2895 if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
2896 goto L9002;
2897 }
2898
2899/* Calculate the size required by the user */
2900 ibyte = *iunit * *isize;
2901
2902/* Find the type of version (Phase of Production or Version Client) */
2903 madbtbk_(&iver);
2904
2905/* Control allocated size in Production phase */
2906
2907 if (iver == 1) {
2908
2909 if (ibyte == 0) {
2910 //s__wsle(&io___3);
2911 //do__lio(&c__9, &c__1, "Require zero allocation", 26L);
2912 AdvApp2Var_SysBase::e__wsle();
2913 maostrb_();
2914 } else if (ibyte >= 4096000) {
2915 //s__wsle(&io___4);
2916 //do__lio(&c__9, &c__1, "Require allocation above 4 Mega-Octets : ", 50L);
2917 //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
2918 AdvApp2Var_SysBase::e__wsle();
2919 maostrb_();
2920 }
2921
2922 }
2923
2924/* CALCULATE THE SIZE OF THE USER ZONE (IZU) */
2925/* . add size required by the user (IBYTE) */
2926/* . add delta for alinement with the base */
2927/* . round to multiple of 8 above */
2928
2929 mcrlocv_((long int)&t[1], (long int *)&loc);
2930 izu = ibyte + loc % *iunit;
2931 irest = izu % 8;
2932 if (irest != 0) {
2933 izu = izu + 8 - irest;
2934 }
2935
2936/* CALCULATE THE SIZE REQUIRED FROM THE PRIMITIVE OF ALLOC */
2937/* . add size of the user zone */
2938/* . add 8 for alinement of start address of */
2939/* allocation on multiple of 8 so that to be able to */
2940/* set flags with Double Precision without other pb than alignement */
2941/* . add 16 octets for two flags */
2942
2943 ibyte = izu + 24;
2944
2945/* DEMAND OF ALLOCATION */
2946
2947 isyst = 0;
2948/* L1001: */
2949/* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
2950/* ALLOCATION SUR TABLE */
2951/* KSYS = 1 */
2952/* KOP = 1 */
2953/* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
2954/* IF ( IER .NE. 0 ) THEN */
2955/* ISYST=1 */
2956/* GOTO 1001 */
2957/* ENDIF */
2958/* ELSE */
2959/* ALLOCATION SYSTEME */
2960 ksys = 2;
2961 mcrgetv_((integer *)&ibyte, (uinteger *)&iaddr, (integer *)&ier);
2962 if (ier != 0) {
2963 goto L9003;
2964 }
2965/* ENDIF */
2966
2967/* CALCULATE THE ADDRESSES OF FLAGS */
2968
2969 iadfd = iaddr + 8 - iaddr % 8;
2970 iadff = iadfd + 8 + izu;
2971
2972/* CALCULATE USER OFFSET : */
2973/* . difference between the user start address and the */
2974/* base address */
2975/* . converts this difference in the user unit */
2976
2977 lofset = iadfd + 8 + loc % *iunit - loc;
2978 *iofset = lofset / *iunit;
2979
2980/* If phase of production control flags */
2981 if (iver == 1) {
2982 macrchk_();
2983 }
2984
2985/* SET FLAGS */
2986/* . the first flag is set by IADFD and the second by IADFF */
2987/* . if phase of production, set to overflow the ZU */
2988 macrgfl_(&iadfd, &iadff, &iver, &izu);
2989
2990/* RANGING OF PARAMETERS IN MCRGENE */
2991
2992 ++mcrgene_.ncore;
2993 mcrgene_.icore[mcrgene_.ncore * 12 - 12] = mcrgene_.lprot;
2994 mcrgene_.icore[mcrgene_.ncore * 12 - 11] = *iunit;
2995 mcrgene_.icore[mcrgene_.ncore * 12 - 10] = *isize;
2996 mcrgene_.icore[mcrgene_.ncore * 12 - 9] = loc;
2997 mcrgene_.icore[mcrgene_.ncore * 12 - 8] = *iofset;
2998 mcrgene_.icore[mcrgene_.ncore * 12 - 7] = ksys;
2999 mcrgene_.icore[mcrgene_.ncore * 12 - 6] = ibyte;
3000 mcrgene_.icore[mcrgene_.ncore * 12 - 5] = iaddr;
3001 mcrgene_.icore[mcrgene_.ncore * 12 - 4] = mcrgene_.ncore;
3002 mcrgene_.icore[mcrgene_.ncore * 12 - 3] = iadfd;
3003 mcrgene_.icore[mcrgene_.ncore * 12 - 2] = iadff;
3004 mcrgene_.icore[mcrgene_.ncore * 12 - 1] = mcrgene_.ncore;
3005
3006 mcrgene_.lprot = 0;
3007
3008/* CALL ALLOWING AUTOIMPLEMENTATION OF THE SET WATCH BY THE DEBUGGER */
3009
3010 macrstw_((integer *)&iadfd, (integer *)&iadff, (integer *)&mcrgene_.ncore);
3011
3012/* STATISTICS */
3013
3014 ++mcrstac_.nrqst[ksys - 1];
3015 mcrstac_.nbyte[ksys - 1] += mcrgene_.icore[mcrgene_.ncore * 12 - 11] *
3016 mcrgene_.icore[mcrgene_.ncore * 12 - 10];
3017/* Computing MAX */
3018 i__1 = mcrstac_.mbyte[ksys - 1], i__2 = mcrstac_.nbyte[ksys - 1];
3019 mcrstac_.mbyte[ksys - 1] = advapp_max(i__1,i__2);
3020
3021 goto L9900;
3022
3023/* ----------------------------------------------------------------------*
3024 */
3025/* ERROR PROCESSING */
3026
3027/* MAX NB OF ALLOC REACHED : */
3028L9001:
3029 *iercod = 1;
3030 ifmt = 1000;
3031 //__s__copy(subr, "MCRRQST", 7L, 7L);
3032 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3033 maostrd_();
3034 goto L9900;
3035
3036/* INCORRECT ARGUMENTS */
3037L9002:
3038 *iercod = 2;
3039 ifmt = *iunit;
3040 //__s__copy(subr, "MCRRQST", 7L, 7L);
3041 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3042 goto L9900;
3043
3044/* SYSTEM REFUSES ALLOCATION */
3045L9003:
3046 *iercod = 3;
3047 ifmt = ibyte;
3048 //__s__copy(subr, "MCRRQST", 7L, 7L);
3049 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3050 maostrd_();
3051 mcrlist_(&ier);
3052 goto L9900;
3053
3054/* ----------------------------------------------------------------------*
3055 */
3056
3057L9900:
3058 mcrgene_.lprot = 0;
3059 return 0 ;
3060} /* mcrrqst_ */
3061
3062//=======================================================================
3063//function : AdvApp2Var_SysBase::mgenmsg_
3064//purpose :
3065//=======================================================================
3066int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
3067 ftnlen )//nomprg_len)
3068
3069{
3070 return 0;
3071} /* mgenmsg_ */
3072
3073//=======================================================================
3074//function : AdvApp2Var_SysBase::mgsomsg_
3075//purpose :
3076//=======================================================================
3077int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
3078 ftnlen )//nomprg_len)
3079
3080{
3081 return 0;
3082} /* mgsomsg_ */
3083
3084
3085/*
3086C
3087C*****************************************************************************
3088C
3089C FUNCTION : CALL MIRAZ(LENGTH,ITAB)
3090C ----------
3091C
3092C RESET TO ZERO A TABLE OF LOGIC OR INTEGER.
3093C
3094C KEYWORDS :
3095C -----------
3096C RAZ INTEGER
3097C
3098C INPUT ARGUMENTS :
3099C ------------------
3100C LENGTH : NUMBER OF OCTETS TO TRANSFER
3101C ITAB : NAME OF THE TABLE
3102C
3103C OUTPUT ARGUMENTS :
3104C -------------------
3105C ITAB : NAME OF THE TABLE SET TO ZERO
3106C
3107C COMMONS USED :
3108C ----------------
3109C
3110C REFERENCES CALLED :
3111C ---------------------
3112C
3113C DEMSCRIPTION/NOTES/LIMITATIONS :
3114C -----------------------------------
3115C
3116C Portable VAX-SGI
3117
3118C>
3119C***********************************************************************
3120*/
3121//=======================================================================
3122//function : AdvApp2Var_SysBase::miraz_
3123//purpose :
3124//=======================================================================
3125void AdvApp2Var_SysBase::miraz_(integer *taille,
3126 char *adt)
3127
3128{
3129 integer offset;
3130 offset = *taille;
3131 memset(adt , '\0' , *taille) ;
3132}
3133//=======================================================================
3134//function : AdvApp2Var_SysBase::mnfndeb_
3135//purpose :
3136//=======================================================================
3137integer AdvApp2Var_SysBase::mnfndeb_()
3138{
3139 integer ret_val;
3140 ret_val = 0;
3141 return ret_val;
3142} /* mnfndeb_ */
3143
3144//=======================================================================
3145//function : AdvApp2Var_SysBase::mnfnimp_
3146//purpose :
3147//=======================================================================
3148integer AdvApp2Var_SysBase::mnfnimp_()
3149{
3150 integer ret_val;
3151 ret_val = 6;
3152 return ret_val;
3153} /* mnfnimp_ */
3154
3155//=======================================================================
3156//function : AdvApp2Var_SysBase::msifill_
3157//purpose :
3158//=======================================================================
3159int AdvApp2Var_SysBase::msifill_(integer *nbintg,
3160 integer *ivecin,
3161 integer *ivecou)
3162{
3163 static integer nocte;
3164
3165/* ***********************************************************************
3166 */
3167
3168/* FUNCTION : */
3169/* ---------- */
3170/* transfer Integer from one zone to another */
3171
3172/* KEYWORDS : */
3173/* ----------- */
3174/* TRANSFER , INTEGER , MEMORY */
3175
3176/* INPUT ARGUMENTS : */
3177/* ------------------ */
3178/* NBINTG : Nb of integers */
3179/* IVECIN : Input vector */
3180
3181/* OUTPUT ARGUMENTS : */
3182/* ------------------- */
3183/* IVECOU : Output vector */
3184
3185/* COMMONS USED : */
3186/* ---------------- */
3187
3188/* REFERENCES CALLED : */
3189/* --------------------- */
3190
3191/* DESCRIPTION/NOTES/LIMITATIONS : */
3192/* ----------------------------------- */
3193
3194/* > */
3195/* ***********************************************************************
3196 */
3197
3198/* ___ NOCTE : Number of octets to transfer */
3199
3200 /* Parameter adjustments */
3201 --ivecou;
3202 --ivecin;
3203
3204 /* Function Body */
3205 nocte = *nbintg * sizeof(integer);
3206 AdvApp2Var_SysBase::mcrfill_((integer *)&nocte, (char *)&ivecin[1], (char *)&ivecou[1]);
3207 return 0 ;
3208} /* msifill_ */
3209
3210//=======================================================================
3211//function : AdvApp2Var_SysBase::msrfill_
3212//purpose :
3213//=======================================================================
3214int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
3215 doublereal *vecent,
3216 doublereal * vecsor)
3217{
3218 static integer nocte;
3219
3220
3221/* ***********************************************************************
3222 */
3223
3224/* FONCTION : */
3225/* ---------- */
3226/* Transfer real from one zone to another */
3227
3228/* KEYWORDS : */
3229/* ----------- */
3230/* TRANSFER , REAL , MEMORY */
3231
3232/* INPUT ARGUMENTS : */
3233/* ----------------- */
3234/* NBREEL : Number of reals */
3235/* VECENT : Input vector */
3236
3237/* OUTPUT ARGUMENTS : */
3238/* ------------------- */
3239/* VECSOR : Output vector */
3240
3241/* COMMONS USED : */
3242/* ---------------- */
3243
3244/* REFERENCES CALLED : */
3245/* ----------------------- */
3246
3247/* DESCRIPTION/NOTES/LIMITATIONS : */
3248/* ----------------------------------- */
3249
3250/* > */
3251/* ***********************************************************************
3252 */
3253
3254/* ___ NOCTE : Nb of octets to transfer */
3255
3256 /* Parameter adjustments */
3257 --vecsor;
3258 --vecent;
3259
3260 /* Function Body */
3261 nocte = *nbreel << 3;
3262 AdvApp2Var_SysBase::mcrfill_((integer *)&nocte, (char *)&vecent[1], (char *)&vecsor[1]);
3263 return 0 ;
3264} /* msrfill_ */
3265
3266//=======================================================================
3267//function : AdvApp2Var_SysBase::mswrdbg_
3268//purpose :
3269//=======================================================================
3270int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
3271 ftnlen )//ctexte_len)
3272
3273{
3274
3275 static cilist io___1 = { 0, 0, 0, 0, 0 };
3276
3277
3278/* ***********************************************************************
3279 */
3280
3281/* FUNCTION : */
3282/* ---------- */
3283/* Write message on console alpha if IBB>0 */
3284
3285/* KEYWORDS : */
3286/* ----------- */
3287/* MESSAGE, DEBUG */
3288
3289/* INPUT ARGUMENTS : */
3290/* ----------------- */
3291/* CTEXTE : Text to be written */
3292
3293/* OUTPUT ARGUMENTS : */
3294/* ------------------- */
3295/* None */
3296
3297/* COMMONS USED : */
3298/* ---------------- */
3299
3300/* REFERENCES CALLED : */
3301/* ----------------------- */
3302
3303/* DESCRIPTION/NOTES/LIMITATIONS : */
3304/* ----------------------------------- */
3305
3306
3307/* > */
3308/* ***********************************************************************
3309 */
3310/* DECLARATIONS */
3311/* ***********************************************************************
3312 */
3313
3314
3315/* ***********************************************************************
3316 */
3317/* PROCESSING */
3318/* ***********************************************************************
3319 */
3320
3321 if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
3322 io___1.ciunit = AdvApp2Var_SysBase::mnfnimp_();
3323 //s__wsle(&io___1);
3324 //do__lio(&c__9, &c__1, "Dbg ", 4L);
3325 //do__lio(&c__9, &c__1, ctexte, ctexte_len);
3326 AdvApp2Var_SysBase::e__wsle();
3327 }
3328 return 0 ;
3329} /* mswrdbg_ */
3330
3331
3332
3333int __i__len()
3334{
3335 return 0;
3336}
3337
3338int __s__cmp()
3339{
3340 return 0;
3341}
3342
3343//=======================================================================
3344//function : do__fio
3345//purpose :
3346//=======================================================================
3347int AdvApp2Var_SysBase::do__fio()
3348{
3349return 0;
3350}
3351//=======================================================================
3352//function : do__lio
3353//purpose :
3354//=======================================================================
3355int AdvApp2Var_SysBase::do__lio ()
3356{
3357 return 0;
3358}
3359//=======================================================================
3360//function : e__wsfe
3361//purpose :
3362//=======================================================================
3363int AdvApp2Var_SysBase::e__wsfe ()
3364{
3365 return 0;
3366}
3367//=======================================================================
3368//function : e__wsle
3369//purpose :
3370//=======================================================================
3371int AdvApp2Var_SysBase::e__wsle ()
3372{
3373 return 0;
3374}
3375//=======================================================================
3376//function : s__wsfe
3377//purpose :
3378//=======================================================================
3379int AdvApp2Var_SysBase::s__wsfe ()
3380{
3381 return 0;
3382}
3383//=======================================================================
3384//function : s__wsle
3385//purpose :
3386//=======================================================================
3387int AdvApp2Var_SysBase::s__wsle ()
3388{
3389 return 0;
3390}
3391
3392
3393/*
3394C*****************************************************************************
3395C
3396C FUNCTION : CALL MVRIRAZ(NBELT,DTAB)
3397C ----------
3398C Reset to zero a table with DOUBLE PRECISION
3399C
3400C KEYWORDS :
3401C -----------
3402C MVRMIRAZ DOUBLE
3403C
3404C INPUT ARGUMENTS :
3405C ------------------
3406C NBELT : Number of elements of the table
3407C DTAB : Table to initializer to zero
3408C
3409C OUTPUT ARGUMENTS :
3410C --------------------
3411C DTAB : Table reset to zero
3412C
3413C COMMONS USED :
3414C ----------------
3415C
3416C REFERENCES CALLED :
3417C -----------------------
3418C
3419C DEMSCRIPTION/NOTES/LIMITATIONS :
3420C -----------------------------------
3421C
3422C
3423C>
3424C***********************************************************************
3425*/
3426//=======================================================================
3427//function : AdvApp2Var_SysBase::mvriraz_
3428//purpose :
3429//=======================================================================
3430void AdvApp2Var_SysBase::mvriraz_(integer *taille,
3431 char *adt)
3432
3433{
3434 integer offset;
3435 offset = *taille * 8 ;
3436 /* printf(" adt %d long %d\n",adt,offset); */
3437 memset(adt , '\0' , offset) ;
3438}