Integration of OCCT 6.5.0 from SVN
[occt.git] / src / AdvApp2Var / AdvApp2Var_SysBase.cxx
CommitLineData
7fd59977 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 /* FONCTION : */
148 /* ---------- */
149 /* INITIALISATION DES UNITES DE LECTURE-ECRITURE, ET DE 'IBB' */
150
151 /* MOTS CLES : */
152 /* ----------- */
153 /* GESTION, CONFIGURATION, UNITES, INITIALISATION */
154
155 /* ARGUMENTS D'ENTREE : */
156 /* -------------------- */
157 /* IMODE : MODE D'INIT : 0= DEFAUT, IMP VAUDRA 6 ET IBB 0 */
158 /* ET LEC 5 */
159 /* 1= FORCE LA VALEUR DE IMP */
160 /* 2= FORCE LA VALEUR DE IBB */
161 /* 3= FORCE LA VALEUR DE LEC */
162
163 /* ARGUMENT UTILISE QUE LORSQUE IMODE VAUT 1 OU 2 : */
164 /* IVAL : VALEUR DE IMP LORSQUE IMODE VAUT 1 */
165 /* VALEUR DE IBB LORSQUE IMODE VAUT 2 */
166 /* VALEUR DE LEC LORSQUE IMODE VAUT 3 */
167 /* IL N'Y A PAS DE CONTROLE SUR LA VALIDITE DE LA VALEUR DE IVAL . */
168
169 /* ARGUMENTS DE SORTIE : */
170 /* --------------------- */
171 /* NEANT */
172
173 /* COMMONS UTILISES : */
174 /* ------------------ */
175 /* REFERENCES APPELEES : */
176 /* --------------------- */
177 /* DESCRIPTION/REMARQUES/LIMITATIONS : */
178 /* ----------------------------------- */
179
180 /* IL NE S'AGIT QUE D'INITIALISER LE COMMON BLANK POUR TOUS LES */
181 /* MODULES QUI N'ONT A PRIORI PAS BESOIN DE CONNAITRE LES COMMONS */
182 /* DE T . */
183 /* LORSQU'UNE MODIFICATION DE IBB EST DEMANDEE (IMODE=2) UN MESSAGE */
184 /* D'INFORMATION EST EMIS SUR IMP, AVEC LA NOUVELLE VALEUR DE IBB. */
185
186 /* IBB : MODE DEBUG DE STRIM T : REGLES D'UTILISATION : */
187 /* 0 VERSION SOBRE */
188 /* >0 LA VERSION A D'AUTANT PLUS DE COMMENTAIRES */
189 /* QUE IBB EST GRAND . */
190 /* PAR EXEMPLE AVEC IBB=1 LES ROUTINES APPELEES */
191 /* SE SIGNALENT SUR IMP ('ENTREE DANS TOTO', */
192 /* ET 'SORTIE DE TOTO'), ET LES ROUTINES RENVOYANT */
193 /* UN CODE ERREUR NON NUL LE SIGNALENT EGALEMENT. */
194 /* (MAIS CECI N'EST PAS VRAI POUR TOUTES LES ROUTINES DE T) */
195
196 /* $ HISTORIQUE DES MODIFICATIONS : */
197 /* ------------------------------ */
198 /* 22-12-89 : DGZ; MODIFICATION EN-TETE */
199 /* 30-05-88 : PP ; AJOUT DE LEC */
200 /* 15-03-88 : PP ; ECRITURE VERSION ORIGINALE */
201 /* > */
202 /* ***********************************************************************
203 */
204
205 if (*imode == 0) {
206 mblank__.imp = 6;
207 mblank__.ibb = 0;
208 mblank__.lec = 5;
209 } else if (*imode == 1) {
210 mblank__.imp = *ival;
211 } else if (*imode == 2) {
212 mblank__.ibb = *ival;
213 io______1.ciunit = mblank__.imp;
214 /*
215 s__wsfe(&io______1);
216 */
217 /*
218 do__fio(&c____1, (char *)&mblank__.ibb, (ftnlen)sizeof(integer));
219 */
220 AdvApp2Var_SysBase::e__wsfe();
221 } else if (*imode == 3) {
222 mblank__.lec = *ival;
223 }
224
225 /* ----------------------------------------------------------------------*
226 */
227
228 return 0;
229} /* macinit__ */
230
231//=======================================================================
232//function : macrai4_
233//purpose :
234//=======================================================================
235int AdvApp2Var_SysBase::macrai4_(integer *nbelem,
236 integer *maxelm,
237 integer *itablo,
238 long int *iofset,
239 integer *iercod)
240
241{
242
243 /* ***********************************************************************
244 */
245
246 /* FONCTION : */
247 /* ---------- */
248 /* Demande d'allocation dynamique de type INTEGER */
249
250 /* MOTS CLES : */
251 /* ----------- */
252 /* SYSTEME, ALLOCATION, MEMOIRE, REALISATION */
253
254 /* ARGUMENTS D'ENTREE : */
255 /* -------------------- */
256 /* NBELEM : Nombre d'unites demandes */
257 /* MAXELM : Nombre maxi d'unites disponibles dans ITABLO */
258 /* ITABLO : Adresse de reference de la zone allouee */
259
260 /* ARGUMENTS DE SORTIE : */
261 /* --------------------- */
262 /* IOFSET : Decalage */
263 /* IERCOD : Code d'erreur */
264 /* = 0 : OK */
265 /* = 1 : Nbre maxi d'allocs atteint */
266 /* = 2 : Arguments incorrects */
267 /* = 3 : Refus d'allocation dynamique */
268
269 /* COMMONS UTILISES : */
270 /* ------------------ */
271
272 /* REFERENCES APPELEES : */
273 /* --------------------- */
274 /* MCRRQST */
275
276 /* DESCRIPTION/REMARQUES/LIMITATIONS : */
277 /* ----------------------------------- */
278 /* (Cf description dans l'entete de MCRRQST) */
279
280 /* Le tableau ITABLO doit etre dimensionne a MAXELM par l'appelant. */
281 /* Si la demande est inferieure ou egale a MAXELM, IOFSET rendu = 0.
282 */
283 /* Sinon, la demande d'allocation est effective et IOFSET > 0. */
284
285 /* $ HISTORIQUE DES MODIFICATIONS : */
286 /* ------------------------------ */
287 /* 16-10-91 : DGZ ; Recuperation version FBI */
288 /* > */
289 /* ***********************************************************************
290 */
291
292 integer iunit;
293 /* Parameter adjustments */
294 --itablo;
295
296
297 iunit = sizeof(integer);
298 /* Function Body */
299 if (*nbelem > *maxelm) {
300 AdvApp2Var_SysBase::mcrrqst_(&iunit, nbelem, (doublereal *)&itablo[1], iofset, iercod);
301 } else {
302 *iercod = 0;
303 *iofset = 0;
304 }
305 return 0 ;
306} /* macrai4_ */
307
308//=======================================================================
309//function : AdvApp2Var_SysBase::macrar8_
310//purpose :
311//=======================================================================
312int AdvApp2Var_SysBase::macrar8_(integer *nbelem,
313 integer *maxelm,
314 doublereal *xtablo,
315 long int *iofset,
316 integer *iercod)
317
318{
319 static integer c__8 = 8;
320
321 /* ***********************************************************************
322 */
323
324 /* FONCTION : */
325 /* ---------- */
326 /* Demande d'allocation dynamique de type DOUBLE PRECISION */
327
328 /* MOTS CLES : */
329 /* ----------- */
330 /* SYSTEME, ALLOCATION, MEMOIRE, REALISATION */
331
332 /* ARGUMENTS D'ENTREE : */
333 /* -------------------- */
334 /* NBELEM : Nombre d'unites demandes */
335 /* MAXELM : Nombre maxi d'unites disponibles dans XTABLO */
336 /* XTABLO : Adresse de reference de la zone allouee */
337
338 /* ARGUMENTS DE SORTIE : */
339 /* --------------------- */
340 /* IOFSET : Decalage */
341 /* IERCOD : Code d'erreur */
342 /* = 0 : OK */
343 /* = 1 : Nbre maxi d'allocs atteint */
344 /* = 2 : Arguments incorrects */
345 /* = 3 : Refus d'allocation dynamique */
346
347 /* COMMONS UTILISES : */
348 /* ------------------ */
349
350 /* REFERENCES APPELEES : */
351 /* --------------------- */
352 /* MCRRQST */
353
354 /* DESCRIPTION/REMARQUES/LIMITATIONS : */
355 /* ----------------------------------- */
356 /* (Cf description dans l'entete de MCRRQST) */
357
358 /* Le tableau XTABLO doit etre dimensionne a MAXELM par l'appelant. */
359 /* Si la demande est inferieure ou egale a MAXELM, IOFSET rendu = 0.
360 */
361 /* Sinon, la demande d'allocation est effective et IOFSET > 0. */
362
363 /* $ HISTORIQUE DES MODIFICATIONS : */
364 /* ------------------------------ */
365 /* 16-10-91 : DGZ ; Recuperation version FBI */
366 /* > */
367 /* ***********************************************************************
368 */
369
370
371 /* Parameter adjustments */
372 --xtablo;
373
374 /* Function Body */
375 if (*nbelem > *maxelm) {
376 AdvApp2Var_SysBase::mcrrqst_(&c__8, nbelem, &xtablo[1], iofset, iercod);
377 } else {
378 *iercod = 0;
379 *iofset = 0;
380 }
381 return 0 ;
382} /* macrar8_ */
383
384//=======================================================================
385//function : macrbrk_
386//purpose :
387//=======================================================================
388int macrbrk_()
389{
390 return 0 ;
391} /* macrbrk_ */
392
393//=======================================================================
394//function : macrchk_
395//purpose :
396//=======================================================================
397int macrchk_()
398{
399 /* System generated locals */
400 integer i__1;
401
402 /* Local variables */
403 static integer i__, j;
404 static long int ioff;
405 static doublereal t[1];
406 static integer loc;
407
408/* ***********************************************************************
409 */
410
411/* FONCTION : */
412/* ---------- */
413/* CONTROLE LES DEBORDEMENTS DE ZONE MEMOIRE ALLOUEES */
414
415/* MOTS CLES : */
416/* ----------- */
417/* SYSTEME, ALLOCATION, MEMOIRE, CONTROLE, DEBORDEMENT */
418
419/* ARGUMENTS D'ENTREE : */
420/* -------------------- */
421/* NEANT */
422
423/* ARGUMENTS DE SORTIE : */
424/* --------------------- */
425/* NEANT */
426
427/* COMMONS UTILISES : */
428/* ------------------ */
429/* MCRGENE */
430
431/* REFERENCES APPELEES : */
432/* --------------------- */
433/* MACRERR, MAOSTRD */
434
435/* DESCRIPTION/REMARQUES/LIMITATIONS : */
436/* ----------------------------------- */
437
438/* $ HISTORIQUE DES MODIFICATIONS : */
439/* ------------------------------ */
440/* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
441/* 18-11-91 : DGZ; AC91118Z0000 : Resactivation */
442/* 17-10-91 : FCR; AC91118Z0000 : Desactivation */
443/* 25-09-91 : DGZ; GESTION DES FLAGS DANS MCRGENE */
444/* 31-07-90 : DGZ; AJOUT TRACE-BACK EN PHASE DE PRODUCTION */
445/* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS . */
446/* 03-10-89 : DGZ; REMPLACE COMMON ACFLAG PAR INCLUDE ACFLAG.INC */
447/* 09-06-89 : PP ; CORRECTION DES CALCULS D'OFFSET */
448/* 31-05-89 : DGZ; APPEL MCRLOCV EN DEHORS BOUCLE DO */
449/* 25-05-89 : DGZ; CHANGE DIM ACRTAB : MALLOC PASSE DE 10000 A 200
450*/
451/* 16-05-89 : PP ; AJOUT DE MACRERR, POUR ARRET SOUS DBG */
452/* 11-05-89 : DGZ ; CREATION DE LA VERSION ORIGINALE */
453/* > */
454/* ***********************************************************************
455 */
456
457/* ***********************************************************************
458 */
459
460/* FONCTION : */
461/* ---------- */
462/* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */
463
464/* MOTS CLES : */
465/* ----------- */
466/* SYSTEME, MEMOIRE, ALLOCATION */
467
468/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
469/* ----------------------------------- */
470
471/* $ HISTORIQUE DES MODIFICATIONS : */
472/* ------------------------------ */
473/* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */
474/* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
475/* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */
476/* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */
477/* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */
478/* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */
479/* + AJOUT DE COMMENTAIRES */
480/* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */
481/* 15-04-85 : BF ; VERSION D'ORIGINE */
482/* > */
483/* ***********************************************************************
484 */
485
486/* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */
487/* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */
488/* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */
489/* 2 : UNITE D'ALLOCATION */
490/* 3 : NB D'UNITES ALLOUEES */
491/* 4 : ADRESSE DE REFERENCE DU TABLEAU */
492/* 5 : IOFSET */
493/* 6 : NUMERO ALLOCATION STATIQUE */
494/* 7 : Taille demandee en allocation */
495/* 8 : adresse du debut de l'allocation */
496/* 9 : Taille de la ZONE UTILISATEUR */
497/* 10 : ADRESSE DU FLAG DE DEBUT */
498/* 11 : ADRESSE DU FLAG DE FIN */
499/* 12 : Rang de creation de l'allocation */
500
501/* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */
502/* NCORE : NBRE D'ALLOCS EN COURS */
503/* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST
504*/
505/* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */
506
507
508
509/* ----------------------------------------------------------------------*
510 */
511
512
513/* ----------------------------------------------------------------------*
514 */
515
516/* CALCUL ADRESSE DE T */
517 mcrlocv_((long int)t, (long int *)&loc);
518
519 /* CONTROLE DES FLAGS DANS LE TABLEAU */
520 i__1 = mcrgene_.ncore;
521 for (i__ = 1; i__ <= i__1; ++i__) {
522
523 for (j = 10; j <= 11; ++j) {
524
525 if (mcrgene_.icore[j + i__ * 12 - 13] != -1) {
526
527 ioff = (mcrgene_.icore[j + i__ * 12 - 13] - loc) / 8;
528
529 if (t[ioff] != -134744073.) {
530
531 /* MSG : '*** ERREUR : ECRASEMENT DE LA MEMOIRE D''ADRESS
532 E:',ICORE(J,I) */
533 /* ET DE RANG ICORE(12,I) */
534 macrerr_((long int *)&mcrgene_.icore[j + i__ * 12 - 13],
535 (integer *)&mcrgene_.icore[i__ * 12 - 1]);
536
537 /* TRACE-BACK EN PHASE DE PRODUCTION */
538 maostrb_();
539
540 /* SUPPRESSION DE L'ADRESSE DU FLAG POUR NE PLUS REFAIRE S
541 ON CONTROLE */
542 mcrgene_.icore[j + i__ * 12 - 13] = -1;
543
544 }
545
546 }
547
548 /* L100: */
549 }
550
551 /* L1000: */
552 }
553 return 0 ;
554} /* macrchk_ */
555
556//=======================================================================
557//function : macrclw_
558//purpose :
559//=======================================================================
560int macrclw_(long int *,//iadfld,
561 long int *,//iadflf,
562 integer *)//nalloc)
563
564{
565 return 0 ;
566} /* macrclw_ */
567
568//=======================================================================
569//function : AdvApp2Var_SysBase::macrdi4_
570//purpose :
571//=======================================================================
572int AdvApp2Var_SysBase::macrdi4_(integer *nbelem,
573 integer *,//maxelm,
574 integer *itablo,
575 long int *iofset, /* Offset en long (pmn) */
576 integer *iercod)
577
578{
579
580 /* ***********************************************************************
581 */
582
583/* FONCTION : */
584/* ---------- */
585/* Destruction d'une allocation dynamique de type INTEGER */
586
587/* MOTS CLES : */
588/* ----------- */
589/* SYSTEME, ALLOCATION, MEMOIRE, DESTRUCTION */
590
591/* ARGUMENTS D'ENTREE : */
592/* -------------------- */
593/* NBELEM : Nombre d'unites demandes */
594/* MAXELM : Nombre maxi d'unites disponibles dans ITABLO */
595/* ITABLO : Adresse de reference de la zone allouee */
596/* IOFSET : Decalage */
597
598/* ARGUMENTS DE SORTIE : */
599/* --------------------- */
600/* IERCOD : Code d'erreur */
601/* = 0 : OK */
602/* = 1 : Pb de de-allocation d'une zone allouee sur table */
603/* = 2 : Le systeme refuse la demande de de-allocation */
604
605/* COMMONS UTILISES : */
606/* ------------------ */
607
608/* REFERENCES APPELEES : */
609/* --------------------- */
610/* MCRDELT */
611
612/* DESCRIPTION/REMARQUES/LIMITATIONS : */
613/* ----------------------------------- */
614/* (Cf description dans l'entete de MCRDELT) */
615
616/* $ HISTORIQUE DES MODIFICATIONS : */
617/* ------------------------------ */
618/* 16-10-91 : DGZ ; Recuperation version FBI */
619/* > */
620/* ***********************************************************************
621 */
622 integer iunit;
623
624 /* Parameter adjustments */
625 --itablo;
626 iunit = sizeof(integer);
627 /* Function Body */
628 if (*iofset != 0) {
629 AdvApp2Var_SysBase::mcrdelt_(&iunit,
630 nbelem,
631 (doublereal *)&itablo[1],
632 iofset,
633 iercod);
634 } else {
635 *iercod = 0;
636 }
637 return 0 ;
638} /* macrdi4_ */
639
640//=======================================================================
641//function : AdvApp2Var_SysBase::macrdr8_
642//purpose :
643//=======================================================================
644int AdvApp2Var_SysBase::macrdr8_(integer *nbelem,
645 integer *,//maxelm,
646 doublereal *xtablo,
647 long int *iofset,
648 integer *iercod)
649
650{
651 static integer c__8 = 8;
652
653/* ***********************************************************************
654 */
655
656/* FONCTION : */
657/* ---------- */
658/* Destruction d'une allocation dynamique de type DOUBLE PRECISION
659*/
660
661/* MOTS CLES : */
662/* ----------- */
663/* SYSTEME, ALLOCATION, MEMOIRE, DESTRUCTION */
664
665/* ARGUMENTS D'ENTREE : */
666/* -------------------- */
667/* NBELEM : Nombre d'unites demandes */
668/* MAXELM : Nombre maxi d'unites disponibles dans XTABLO */
669/* XTABLO : Adresse de reference de la zone allouee */
670/* IOFSET : Decalage */
671
672/* ARGUMENTS DE SORTIE : */
673/* --------------------- */
674/* IERCOD : Code d'erreur */
675/* = 0 : OK */
676/* = 1 : Pb de de-allocation d'une zone allouee sur table */
677/* = 2 : Le systeme refuse la demande de de-allocation */
678
679/* COMMONS UTILISES : */
680/* ------------------ */
681
682/* REFERENCES APPELEES : */
683/* --------------------- */
684/* MCRDELT */
685
686/* DESCRIPTION/REMARQUES/LIMITATIONS : */
687/* ----------------------------------- */
688/* (Cf description dans l'entete de MCRDELT) */
689
690/* $ HISTORIQUE DES MODIFICATIONS : */
691/* ------------------------------ */
692/* 16-10-91 : DGZ ; Recuperation version FBI */
693/* > */
694/* ***********************************************************************
695 */
696
697
698 /* Parameter adjustments */
699 --xtablo;
700
701 /* Function Body */
702 if (*iofset != 0) {
703 AdvApp2Var_SysBase::mcrdelt_(&c__8, nbelem, &xtablo[1], iofset, iercod);
704 } else {
705 *iercod = 0;
706 }
707 return 0 ;
708} /* macrdr8_ */
709
710//=======================================================================
711//function : macrerr_
712//purpose :
713//=======================================================================
714int macrerr_(long int *,//iad,
715 integer *)//nalloc)
716
717{
718 //static integer c__1 = 1;
719 /* Builtin functions */
720 //integer /*s__wsfe(),*/ /*do__fio(),*/ e__wsfe();
721
722 /* Fortran I/O blocks */
723 //static cilist io___1 = { 0, 6, 0, "(X,A,I9,A,I3)", 0 };
724
725/* ***********************************************************************
726 */
727
728/* FONCTION : */
729/* ---------- */
730/* ECRITURE D'UNE ADRESSE ECRASEE DANS LES ALLOCS . */
731
732/* MOTS CLES : */
733/* ----------- */
734/* ALLOC CONTROLE */
735
736/* ARGUMENTS D'ENTREE : */
737/* -------------------- */
738/* IAD : ADRESSE A SIGNALER ECRASEE */
739/* NALLOC : NUMERO DE L'ALLOCATION */
740
741/* ARGUMENTS DE SORTIE : */
742/* --------------------- */
743/* NEANT */
744
745/* COMMONS UTILISES : */
746/* ------------------ */
747
748/* REFERENCES APPELEES : */
749/* --------------------- */
750
751/* DESCRIPTION/REMARQUES/LIMITATIONS : */
752/* ----------------------------------- */
753
754/* $ HISTORIQUE DES MODIFICATIONS : */
755/* ------------------------------ */
756/* 30-09-91 : DGZ; AJOUT DU NUMERO DE L'ALLOCATION */
757/* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS . */
758/* 17-05-89 : PP ; CREATION */
759/* > */
760/* ***********************************************************************
761 */
762 /*
763 s__wsfe(&io___1);
764 */
765 /*
766 do__fio(&c__1, "*** ERREUR : Ecrasement de la memoire d'adresse ", 48L);
767 do__fio(&c__1, (char *)&(*iad), (ftnlen)sizeof(long int));
768 do__fio(&c__1, " sur l'allocation ", 18L);
769 do__fio(&c__1, (char *)&(*nalloc), (ftnlen)sizeof(integer));
770 */
771 AdvApp2Var_SysBase::e__wsfe();
772
773 return 0 ;
774} /* macrerr_ */
775
776
777//=======================================================================
778//function : macrgfl_
779//purpose :
780//=======================================================================
781int macrgfl_(long int *iadfld,
782 long int *iadflf,
783 integer *iphase,
784 integer *iznuti)
785
786{
787 /* Initialized data */
788
789 static integer ifois = 0;
790
791 static char cbid[1];
792 static integer ibid, ienr;
793 static doublereal t[1];
794 static integer novfl;
795 static long int ioff,iadrfl, iadt;
796
797
798 /* ***********************************************************************
799 */
800
801 /* FONCTION : */
802 /* ---------- */
803 /* MISE EN PLACE DES DEUX FLAGS DE DEBUT ET DE FIN DE LA ZONE */
804 /* ALLOUEE ET MISE A OVERFLOW DE L'ESPACE UTILISATEUR EN PHASE */
805 /* DE PRODUCTION. */
806
807 /* MOTS CLES : */
808 /* ----------- */
809 /* ALLOCATION, CONTROLE, DEBORDEMENT */
810
811 /* ARGUMENTS D'ENTREE : */
812 /* -------------------- */
813 /* IADFLD : ADRESSE DU FLAG DE DEBUT */
814 /* IADFLF : ADRESSE DU FLAG DE FIN */
815 /* IPHASE : TYPE DE VERSION LOGICIELLE : */
816 /* 0 = VERSION OFFICIELLE */
817 /* 1 = VERSION PRODUCTION */
818 /* IZNUTI : TAILLE DE LA ZONE UTILISATEUR EN OCTETS */
819
820 /* ARGUMENTS DE SORTIE : */
821 /* --------------------- */
822 /* NEANT */
823
824 /* COMMONS UTILISES : */
825 /* ------------------ */
826
827 /* REFERENCES APPELEES : */
828 /* --------------------- */
829 /* CRLOCT,MACRCHK */
830
831 /* DESCRIPTION/REMARQUES/LIMITATIONS : */
832 /* ----------------------------------- */
833
834 /* $ HISTORIQUE DES MODIFICATIONS : */
835 /* ------------------------------ */
836 /* 25-09-91 : DGZ ; GERE LES FLAGS DANS LE COMMUN MCRGENE */
837 /* 21-08-90 : DGZ ; APPELS DE MACRCHK DANS LES DEUX CAS (AJOUT,SUPP)
838 */
839 /* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS . */
840 /* 03-10-89 : DGZ ; REMPLACE COMMON ACFLAG PAR INCLUDE ACFLAG.INC */
841 /* 09-06-89 : PP ; CORRECTION DU CALCUL DE L'OFFSET */
842 /* 31-05-89 : DGZ ; OPTIMISATION DE LA GESTION DU TABLEAU DES FLAGS
843 */
844 /* 23-05-89 : DGZ ; CORRECTION DEBORDEMENT DU TABLEAU ACRTAB */
845 /* 11-05-89 : DGZ ; CREATION DE LA VERSION ORIGINALE */
846 /* > */
847 /* ***********************************************************************
848 */
849
850
851
852 /* ***********************************************************************
853 */
854
855 /* FONCTION : */
856 /* ---------- */
857 /* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */
858
859 /* MOTS CLES : */
860 /* ----------- */
861 /* SYSTEME, MEMOIRE, ALLOCATION */
862
863 /* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
864 /* ----------------------------------- */
865
866 /* $ HISTORIQUE DES MODIFICATIONS : */
867 /* ------------------------------ */
868 /* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */
869 /* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
870 /* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */
871 /* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */
872 /* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */
873 /* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */
874 /* + AJOUT DE COMMENTAIRES */
875 /* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */
876 /* 15-04-85 : BF ; VERSION D'ORIGINE */
877 /* > */
878 /* ***********************************************************************
879 */
880
881 /* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */
882 /* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */
883 /* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */
884 /* 2 : UNITE D'ALLOCATION */
885 /* 3 : NB D'UNITES ALLOUEES */
886 /* 4 : ADRESSE DE REFERENCE DU TABLEAU */
887 /* 5 : IOFSET */
888 /* 6 : NUMERO ALLOCATION STATIQUE */
889 /* 7 : Taille demandee en allocation */
890 /* 8 : adresse du debut de l'allocation */
891 /* 9 : Taille de la ZONE UTILISATEUR */
892 /* 10 : ADRESSE DU FLAG DE DEBUT */
893 /* 11 : ADRESSE DU FLAG DE FIN */
894 /* 12 : Rang de creation de l'allocation */
895
896 /* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */
897 /* NCORE : NBRE D'ALLOCS EN COURS */
898 /* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST
899 */
900 /* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */
901
902
903
904 /* ----------------------------------------------------------------------*
905 */
906
907
908 if (ifois == 0) {
909 matrsym_("NO_OVERFLOW", cbid, &novfl, &ibid, 11L, 1L);
910 ifois = 1;
911 }
912
913 /* CALCUL DE L'ADRESSE DE T */
914 mcrlocv_((long int)t, (long int *)&iadt);
915
916 /* CALCUL DE l"OFFSET */
917 ioff = (*iadfld - iadt) / 8;
918
919 /* MISE A OVERFLOW DE LA ZONE UTILISATEUR EN CAS DE VERSION PRODUCTION */
920 if (*iphase == 1 && novfl == 0) {
921 ienr = *iznuti / 8;
922 maoverf_(&ienr, &t[ioff + 1]);
923 }
924
925 /* MISE A JOUR DU FLAG DE DEBUT */
926 t[ioff] = -134744073.;
927
928 /* APPEL BIDON POUR PERMETTRE L'ARRET AU DEBUGGER : */
929 iadrfl = *iadfld;
930 macrbrk_();
931
932 /* MISE A JOUR DU FLAG DE DEBUT */
933 ioff = (*iadflf - iadt) / 8;
934 t[ioff] = -134744073.;
935
936 /* APPEL BIDON POUR PERMETTRE L'ARRET AU DEBUGGER : */
937 iadrfl = *iadflf;
938 macrbrk_();
939
940 return 0 ;
941} /* macrgfl_ */
942
943//=======================================================================
944//function : macrmsg_
945//purpose :
946//=======================================================================
947int macrmsg_(const char *,//crout,
948 integer *,//num,
949 integer *it,
950 doublereal *xt,
951 const char *ct,
952 ftnlen ,//crout_len,
953 ftnlen ct_len)
954
955{
956
957 /* Local variables */
958 static integer inum, iunite;
959 static char cfm[80], cln[3];
960
961 /* Fortran I/O blocks */
962 static cilist io___5 = { 0, 0, 0, cfm, 0 };
963 static cilist io___6 = { 0, 0, 0, cfm, 0 };
964 static cilist io___7 = { 0, 0, 0, cfm, 0 };
965
966
967/* ***********************************************************************
968 */
969
970/* FONCTION : */
971/* ---------- */
972/* MESSAGERIE DES ROUTINES D'ALLOC */
973
974/* MOTS CLES : */
975/* ----------- */
976/* ALLOC,MESSAGE */
977
978/* ARGUMENTS D'ENTREE : */
979/* -------------------- */
980/* CROUT : NOM DE LA ROUTINE APPELANTE : MCRRQST, MCRDELT, MCRLIST
981*/
982/* ,CRINCR OU CRPROT */
983/* NUM : NUMERO DU MESSAGE */
984/* IT : TABLEAU DE DONNEES ENTIERES */
985/* XT : TABLEAU DE DONNEES REELLES */
986/* CT : ------------------ CHARACTER */
987
988/* ARGUMENTS DE SORTIE : */
989/* --------------------- */
990/* NEANT */
991
992/* COMMONS UTILISES : */
993/* ------------------ */
994
995/* REFERENCES APPELEES : */
996/* --------------------- */
997
998/* DESCRIPTION/REMARQUES/LIMITATIONS : */
999/* ----------------------------------- */
1000
1001/* ROUTINE A USAGE TEMPORAIRE, EN ATTENDANT LA 'NOUVELLE' MESSAGERIE */
1002/* (STRIM 3.3 ?) , POUR RENDRE LES ROUTINES D'ALLOC UTILISABLES */
1003/* AILLEURS QUE DANS STRIM T-M . */
1004
1005/* EN FONCTION DE LA LANGUE, ECRITURE DU MESSAGE DEMANDE SUR */
1006/* L'UNITE IMP . */
1007/* (REPRISE DES SPECIFS DE VFORMA) */
1008
1009/* LE MESSAGE EST INITIALISE A 'IL MANQUE LE MESSAGE', ET CELUI-LA */
1010/* EST REMPLACE PAR LE MESSAGE DEMANDE S'IL EXISTE . */
1011
1012
1013/* LES MESSAGES FRANCAIS ONT ETE PRIS DANS LA 3.2 LE 26.2.88, ALORS */
1014/* QUE LES ANGLAIS ONT ETE PRIS DANS ENGUS, ET QUE LES */
1015/* ALLEMANDS VIENNENT DE LA 312 . */
1016
1017
1018/* $ HISTORIQUE DES MODIFICATIONS : */
1019/* ------------------------------ */
1020/* 4-09-1991 : FCR ; MENAGE */
1021/* 02-05-88 : PP ; CORRECTION DE SYNTAXE DE FORMAT */
1022/* 26.2.88 : PP ECRITURE VERSION ORIGINALE . */
1023/* > */
1024/* ***********************************************************************
1025 */
1026
1027/* LOCAL : */
1028
1029/* ----------------------------------------------------------------------*
1030 */
1031/* RECHERCHE DU MESSAGE EN FONCTION DE LA LANGUE , DE LA ROUTINE */
1032/* CONCERNEE, ET DU NUMERO DE MESSAGE */
1033
1034/* LECTURE DE LA LANGUE : */
1035 /* Parameter adjustments */
1036 ct -= ct_len;
1037 --xt;
1038 --it;
1039
1040 /* Function Body */
1041 mamdlng_(cln, 3L);
1042
1043/* INUM : TYPE DE MESSAGE : 0 QUE DU TEXTE, 1 1 ENTIER A ECRIRE */
1044/* -1 MESSAGE INEXISTANT (1 ENTIER ET 1 CHAINE) */
1045
1046 inum = -1;
1047/*
1048 if (__s__cmp(cln, "FRA", 3L, 3L) == 0) {
1049 __s__copy(cfm, "(' Il manque le message numero ',I5' pour le programm\
1050e de nom : ',A8)", 80L, 71L);
1051 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1052 if (*num == 1) {
1053 inum = 1;
1054 __s__copy(cfm, "(/,' Nombre d''allocation(s) de memoire effectu\
1055ee(s) : ',I6,/)", 80L, 62L);
1056 } else if (*num == 2) {
1057 inum = 1;
1058 __s__copy(cfm, "(' Taille de l''allocation = ',I12)", 80L, 35L);
1059 } else if (*num == 3) {
1060 inum = 1;
1061 __s__copy(cfm, "(' Taille totale allouee = ',I12 /)", 80L, 36L);
1062 }
1063 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1064 if (*num == 1) {
1065 inum = 0;
1066 __s__copy(cfm, "(' L''allocation de memoire a detruire n''exist\
1067e pas ')", 80L, 56L);
1068 } else if (*num == 2) {
1069 inum = 0;
1070 __s__copy(cfm, "(' Le systeme refuse une destruction d''allocat\
1071ion de memoire ')", 80L, 65L);
1072 }
1073 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1074 if (*num == 1) {
1075 inum = 1;
1076 __s__copy(cfm, "(' Le nombre maxi d''allocations de memoire est\
1077 atteint :',I6)", 80L, 62L);
1078 } else if (*num == 2) {
1079 inum = 1;
1080 __s__copy(cfm, "(' Unite d''allocation invalide : ',I12)", 80L,
1081 40L);
1082 } else if (*num == 3) {
1083 inum = 1;
1084 __s__copy(cfm, "(' Le systeme refuse une allocation de memoire \
1085de ',I12,' octets')", 80L, 66L);
1086 }
1087 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1088 if (*num == 1) {
1089 inum = 0;
1090 __s__copy(cfm, "(' L''allocation de memoire a incrementer n''ex\
1091iste pas')", 80L, 57L);
1092 }
1093 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1094 if (*num == 1) {
1095 inum = 1;
1096 __s__copy(cfm, "(' Le niveau de protection est invalide ( =< 0 \
1097) : ',I12)", 80L, 57L);
1098 }
1099 }
1100
1101 } else if (__s__cmp(cln, "DEU", 3L, 3L) == 0) {
1102 __s__copy(cfm, "(' Es fehlt die Meldung Nummer ',I5,' fuer das Progra\
1103mm des Namens : ',A8)", 80L, 76L);
1104 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1105 if (*num == 1) {
1106 inum = 1;
1107 __s__copy(cfm, "(/,' Anzahl der ausgefuehrten dynamischen Anwei\
1108sung(en) : ',I6,/)", 80L, 65L);
1109 } else if (*num == 2) {
1110 inum = 1;
1111 __s__copy(cfm, "(' Groesse der Zuweisung = ',I12)", 80L, 33L);
1112 } else if (*num == 3) {
1113 inum = 1;
1114 __s__copy(cfm, "(' Gesamtgroesse der Zuweisung = ',I12,/)", 80L,
1115 41L);
1116 }
1117 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1118 if (*num == 1) {
1119 inum = 0;
1120 __s__copy(cfm, "(' Zu loeschende dynamische Zuweisung existiert\
1121 nicht !! ')", 80L, 59L);
1122 } else if (*num == 2) {
1123 inum = 0;
1124 __s__copy(cfm, "(' System verweigert Loeschung der dynamischen \
1125Zuweisung !!')", 80L, 61L);
1126 }
1127 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1128 if (*num == 1) {
1129 inum = 1;
1130 __s__copy(cfm, "(' Hoechstzahl dynamischer Zuweisungen ist erre\
1131icht :',I6)", 80L, 58L);
1132 } else if (*num == 2) {
1133 inum = 1;
1134 __s__copy(cfm, "(' Falsche Zuweisungseinheit : ',I12)", 80L, 37L)
1135 ;
1136 } else if (*num == 3) {
1137 inum = 1;
1138 __s__copy(cfm, "(' System verweigert dynamische Zuweisung von '\
1139,I12,' Bytes')", 80L, 61L);
1140 }
1141 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1142 if (*num == 1) {
1143 inum = 0;
1144 __s__copy(cfm, "(' Zu inkrementierende dynamische Zuweisung exi\
1145stiert nicht !! ')", 80L, 65L);
1146 }
1147 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1148 if (*num == 1) {
1149 inum = 1;
1150 __s__copy(cfm, "(' Sicherungsniveau ist nicht richtig ( =< 0 ) \
1151: ',I12)", 80L, 55L);
1152 }
1153 }
1154
1155 } else {
1156 __s__copy(cfm, "(' Message number ',I5,' is missing ' \
1157 ,'for program named: ',A8)", 80L, 93L);
1158 if (__s__cmp(crout, "MCRLIST", crout_len, 7L) == 0) {
1159 if (*num == 1) {
1160 inum = 1;
1161 __s__copy(cfm, "(/,' number of memory allocations carried out: \
1162',I6,/)", 80L, 54L);
1163 } else if (*num == 2) {
1164 inum = 1;
1165 __s__copy(cfm, "(' size of allocation = ',I12)", 80L, 30L);
1166 } else if (*num == 3) {
1167 inum = 1;
1168 __s__copy(cfm, "(' total size allocated = ',I12,/)", 80L, 34L);
1169 }
1170 } else if (__s__cmp(crout, "MCRDELT", crout_len, 7L) == 0) {
1171 if (*num == 1) {
1172 inum = 0;
1173 __s__copy(cfm, "(' Memory allocation to delete does not exist !\
1174! ')", 80L, 51L);
1175 } else if (*num == 2) {
1176 inum = 0;
1177 __s__copy(cfm, "(' System refuses deletion of memory allocation\
1178 !! ')", 80L, 53L);
1179 }
1180 } else if (__s__cmp(crout, "MCRRQST", crout_len, 7L) == 0) {
1181 if (*num == 1) {
1182 inum = 1;
1183 __s__copy(cfm, "(' max number of memory allocations reached :',\
1184I6)", 80L, 50L);
1185 } else if (*num == 2) {
1186 inum = 1;
1187 __s__copy(cfm, "(' incorrect unit of allocation : ',I12)", 80L,
1188 40L);
1189 } else if (*num == 3) {
1190 inum = 1;
1191 __s__copy(cfm, "(' system refuses a memory allocation of ',I12,\
1192' bytes ')", 80L, 57L);
1193 }
1194 } else if (__s__cmp(crout, "CRINCR", crout_len, 6L) == 0) {
1195 if (*num == 1) {
1196 inum = 0;
1197 __s__copy(cfm, "(' Memory allocation to increment does not exis\
1198t !! ')", 80L, 54L);
1199 }
1200 } else if (__s__cmp(crout, "CRPROT", crout_len, 6L) == 0) {
1201 if (*num == 1) {
1202 inum = 1;
1203 __s__copy(cfm, "(' level of protection is incorrect ( =< 0 ) : \
1204',I12)", 80L, 53L);
1205 }
1206 }
1207 }
1208 */
1209 /* ----------------------------------------------------------------------*
1210 */
1211 /* REALISATION DU WRITE , AVEC OU SANS DONNEES : */
1212
1213 iunite = AdvApp2Var_SysBase::mnfnimp_();
1214 if (inum == 0) {
1215 io___5.ciunit = iunite;
1216 /*
1217 s__wsfe(&io___5);
1218 */
1219 AdvApp2Var_SysBase::e__wsfe();
1220 } else if (inum == 1) {
1221 io___6.ciunit = iunite;
1222 /*
1223 s__wsfe(&io___6);
1224 */
1225 /*
1226 do__fio(&c__1, (char *)&it[1], (ftnlen)sizeof(integer));
1227 */
1228 AdvApp2Var_SysBase::e__wsfe();
1229 } else {
1230 /* LE MESSAGE N'EXISTE PAS ... */
1231 io___7.ciunit = iunite;
1232 /*
1233 s__wsfe(&io___7);
1234 */
1235 /*
1236 do__fio(&c__1, (char *)&(*num), (ftnlen)sizeof(integer));
1237 do__fio(&c__1, crout, crout_len);
1238 */
1239 AdvApp2Var_SysBase::e__wsfe();
1240 }
1241
1242 return 0;
1243} /* macrmsg_ */
1244//=======================================================================
1245//function : macrstw_
1246//purpose :
1247//=======================================================================
1248int macrstw_(integer *,//iadfld,
1249 integer *,//iadflf,
1250 integer *)//nalloc)
1251
1252{
1253 return 0 ;
1254} /* macrstw_ */
1255
1256//=======================================================================
1257//function : madbtbk_
1258//purpose :
1259//=======================================================================
1260int madbtbk_(integer *indice)
1261{
1262 *indice = 0;
1263 return 0 ;
1264} /* madbtbk_ */
1265
1266//=======================================================================
1267//function : AdvApp2Var_SysBase::maermsg_
1268//purpose :
1269//=======================================================================
1270int AdvApp2Var_SysBase::maermsg_(const char *,//cnompg,
1271 integer *,//icoder,
1272 ftnlen )//cnompg_len)
1273
1274{
1275 return 0 ;
1276} /* maermsg_ */
1277
1278//=======================================================================
1279//function : magtlog_
1280//purpose :
1281//=======================================================================
1282int magtlog_(const char *cnmlog,
1283 const char *,//chaine,
1284 integer *long__,
1285 integer *iercod,
1286 ftnlen cnmlog_len,
1287 ftnlen )//chaine_len)
1288
1289{
1290
1291 /* Local variables */
1292 static char cbid[255];
1293 static integer ibid, ier;
1294
1295
1296/* **********************************************************************
1297*/
1298
1299/* FONCTION : */
1300/* ---------- */
1301/* RENVOIE LA TRADUCTION D'UN "NOM LOGIQUE STRIM" DANS LA */
1302/* "SYNTAXE INTERNE" CORRESPONDANT A UN "LIEU DE RANGEMENT" */
1303
1304/* MOTS CLES : */
1305/* ----------- */
1306/* NOM LOGIQUE STRIM , TRADUCTION */
1307
1308/* ARGUMENTS D'ENTREE : */
1309/* ------------------ */
1310/* CNMLOG : NOM DU "NOM LOGIQUE STRIM" A TRADUIRE */
1311
1312/* ARGUMENTS DE SORTIE : */
1313/* ------------------- */
1314/* CHAINE : ADRESSE DU "LIEU DE RANGEMENT" */
1315/* LONG : LONGUEUR UTILE DU "LIEU DE RANGEMENT" */
1316/* IERCOD : CODE D'ERREUR */
1317/* IERCOD = 0 : OK */
1318/* IERCOD = 5 : LIEU DE RANGEMENT CORRESPONDANT AU NOM LOGIQUE */
1319/* INEXISTANT */
1320/* IERCOD = 6 : TRADUCTION TROP LONGUE POUR LA VARIABLE 'CHAINE' */
1321/* IERCOD = 7 : ERREUR SEVERE */
1322
1323/* COMMONS UTILISES : */
1324/* ---------------- */
1325/* NEANT */
1326
1327/* REFERENCES APPELEES : */
1328/* ----------------------- */
1329/* GNMLOG, MACHDIM */
1330
1331/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1332/* ----------------------------------- */
1333
1334/* ROUTINE SPECIFIQUE SGI */
1335
1336/* DANS TOUS LES CAS OU IERCOD EST >0,AUCUN RESULTAT N'EST RENVOYE
1337*/
1338
1339/* NOTION DE "SYNTAXE UTILISATEUR' ET "SYNTAXE INTERNE" */
1340/* --------------------------------------------------- */
1341
1342/* LA "SYNTAXE UTILISATEUR" EST LA SYNTAXE DANS LAQUELLE L'UTILISATE
1343UR*/
1344/* VISUALISE OU DESIGNE UN NOM DE FICHIER OU LE NOM REPERTOIRE AU
1345*/
1346/* COURS D'UNE SESSION DE STRIM100 */
1347
1348/* LA "SYNTAXE INTERNE" EST LA SYNTAXE UTILISEE POUR EFFECTUER DES
1349*/
1350/* OPERATIONS DE TRAITEMENTS DE FICHIERS A L'INTERIEUR DU CODE */
1351/* (OPEN,INQUIRE,...ETC) */
1352
1353/* $ HISTORIQUE DES MODIFICATIONS : */
1354/* -------------------------------- */
1355
1356/* 08-01-91 : B. Achispon ; Mise en forme et suppresion appel a MACHDIM
1357*/
1358/* 26-10-88 : C. Guinamard ; Adaptation UNIX Traduction effective */
1359/* du nom logique */
1360/* 10-08-88 : DGZ ; CHANGE BNMLOG PAR MATRLOG */
1361/* 05-02-88 : DGZ ; MODIF D'ENTETE */
1362/* 26-08-87 : DGZ ; APPEL DE BNMLOG */
1363/* 25-08-87 : BJ ; MODIF ENTETE */
1364/* 24-12-86 : DGZ ; CREATION VERSION ORIGINALE */
1365
1366/* > */
1367/* ***********************************************************************
1368 */
1369/* DECLARATIONS */
1370/* ***********************************************************************
1371 */
1372
1373
1374/* ***********************************************************************
1375 */
1376/* TRAITEMENT */
1377/* ***********************************************************************
1378 */
1379
1380 *long__ = 0;
1381 *iercod = 0;
1382
1383 /* CONTROLE DE L'EXISTENCE DU NOM LOGIQUE */
1384
1385 matrlog_(cnmlog, cbid, &ibid, &ier, cnmlog_len, 255L);
1386 if (ier == 1) {
1387 goto L9500;
1388 }
1389 if (ier == 2) {
1390 goto L9700;
1391 }
1392
1393 /* CONTROLE DE LA LONGUEUR DE CHAINE */
1394
1395 if (ibid > __i__len()/*chaine, chaine_len)*/) {
1396 goto L9600;
1397 }
1398
1399 //__s__copy(chaine, cbid, chaine_len, ibid);
1400 *long__ = ibid;
1401
1402 goto L9999;
1403
1404 /* ***********************************************************************
1405 */
1406 /* TRAITEMENT DES ERREURS */
1407 /* ***********************************************************************
1408 */
1409
1410 L9500:
1411 *iercod = 5;
1412 //__s__copy(chaine, " ", chaine_len, 1L);
1413 goto L9999;
1414
1415 L9600:
1416 *iercod = 6;
1417 //__s__copy(chaine, " ", chaine_len, 1L);
1418 goto L9999;
1419
1420 L9700:
1421 *iercod = 7;
1422 //__s__copy(chaine, " ", chaine_len, 1L);
1423
1424 /* ***********************************************************************
1425 */
1426 /* RETOUR AU PROGRAMME APPELANT */
1427 /* ***********************************************************************
1428 */
1429
1430 L9999:
1431 return 0;
1432} /* magtlog_ */
1433
1434//=======================================================================
1435//function : mainial_
1436//purpose :
1437//=======================================================================
1438int AdvApp2Var_SysBase::mainial_()
1439{
1440 mcrgene_.ncore = 0;
1441 return 0 ;
1442} /* mainial_ */
1443
1444//=======================================================================
1445//function : AdvApp2Var_SysBase::maitbr8_
1446//purpose :
1447//=======================================================================
1448int AdvApp2Var_SysBase::maitbr8_(integer *itaill,
1449 doublereal *xtab,
1450 doublereal *xval)
1451
1452{
1453 static integer c__504 = 504;
1454
1455 /* Initialized data */
1456
1457 static doublereal buff0[63] = {
1458 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1459 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1460 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1461 0.,0.,0.,0.,0.
1462 };
1463
1464 /* System generated locals */
1465 integer i__1;
1466
1467 /* Local variables */
1468 static integer i__;
1469 static doublereal buffx[63];
1470 static integer nbfois, noffst, nreste, nufois;
1471
1472/* ***********************************************************************
1473 */
1474
1475/* FONCTION : */
1476/* ---------- */
1477/* INITIALISATION A UNE VALEUR DONNEE D'UN TABLEAU DE REEL *8 */
1478
1479/* MOTS CLES : */
1480/* ----------- */
1481/* MANIPULATIONS, MEMOIRE, INITIALISATION, DOUBLE-PRECISION */
1482
1483/* ARGUMENTS D'ENTREE : */
1484/* -------------------- */
1485/* ITAILL : TAILLE DU TABLEAU */
1486/* XTAB : TABLEAU A INITIALISER AVEC XVAL */
1487/* XVAL : VALEUR A METTRE DANS XTAB(1 A ITAILL) */
1488
1489/* ARGUMENTS DE SORTIE : */
1490/* --------------------- */
1491/* XTAB : TABLEAU INITIALISE */
1492
1493/* COMMONS UTILISES : */
1494/* ------------------ */
1495
1496/* REFERENCES APPELEES : */
1497/* --------------------- */
1498
1499/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1500/* ----------------------------------- */
1501
1502/* ON APPELLE MCRFILL QUI FAIT DES MOVE PAR PAQUETS DE 63 REELS */
1503
1504/* LE PAQUET INITIAL EST BUFF0 INITE PAR DATA SI LA VALEUR EST 0 */
1505/* OU BUFFX INITE PAR XVAL (BOUCLE) SINON . */
1506
1507
1508/* PORTABILITE : OUI */
1509/* ACCES : LIBRE */
1510
1511/* $ HISTORIQUE DES MODIFICATIONS : */
1512/* ------------------------------ */
1513/* 13-11-1991 : FCR ; VERFOR : Menage */
1514/* 06-05-91 : DGZ; MODIFICATION EN-TETE */
1515/* 05-07-88 : PP ; OPTIMISATION PAR POMPAGE SUR MVRMIRAZ */
1516/* 28-04-88 : PP ; CREATION */
1517/* > */
1518/* ***********************************************************************
1519 */
1520
1521
1522 /* Parameter adjustments */
1523 --xtab;
1524
1525 /* Function Body */
1526
1527 /* ----------------------------------------------------------------------*
1528 */
1529
1530 nbfois = *itaill / 63;
1531 noffst = nbfois * 63;
1532 nreste = *itaill - noffst;
1533
1534 if (*xval == 0.) {
1535 if (nbfois >= 1) {
1536 i__1 = nbfois;
1537 for (nufois = 1; nufois <= i__1; ++nufois) {
1538 AdvApp2Var_SysBase::mcrfill_(&c__504, (char *)buff0, (char *)&xtab[(nufois - 1) * 63 + 1]);
1539 /* L1000: */
1540 }
1541 }
1542
1543 if (nreste >= 1) {
1544 i__1 = nreste << 3;
1545 AdvApp2Var_SysBase::mcrfill_(&i__1, (char *)buff0, (char *)&xtab[noffst + 1]);
1546 }
1547 } else {
1548 for (i__ = 1; i__ <= 63; ++i__) {
1549 buffx[i__ - 1] = *xval;
1550 /* L2000: */
1551 }
1552 if (nbfois >= 1) {
1553 i__1 = nbfois;
1554 for (nufois = 1; nufois <= i__1; ++nufois) {
1555 AdvApp2Var_SysBase::mcrfill_(&c__504, (char *)buffx, (char *)&xtab[(nufois - 1) * 63 + 1]);
1556 /* L3000: */
1557 }
1558 }
1559
1560 if (nreste >= 1) {
1561 i__1 = nreste << 3;
1562 AdvApp2Var_SysBase::mcrfill_(&i__1, (char *)buffx, (char *)&xtab[noffst + 1]);
1563 }
1564 }
1565
1566 /* ----------------------------------------------------------------------*
1567 */
1568
1569 return 0;
1570} /* maitbr8_ */
1571
1572//=======================================================================
1573//function : mamdlng_
1574//purpose :
1575//=======================================================================
1576int mamdlng_(char *,//cmdlng,
1577 ftnlen )//cmdlng_len)
1578
1579{
1580
1581
1582/* ***********************************************************************
1583 */
1584
1585/* FONCTION : */
1586/* ---------- */
1587/* RENVOIE LA LANGUE COURANTE */
1588
1589/* MOTS CLES : */
1590/* ----------- */
1591/* GESTION, CONFIGURATION, LANGUE, LECTURE */
1592
1593/* ARGUMENTS D'ENTREE : */
1594/* -------------------- */
1595/* CMDLNG : LANGUE */
1596
1597/* ARGUMENTS DE SORTIE : */
1598/* --------------------- */
1599/* NEANT */
1600
1601/* COMMONS UTILISES : */
1602/* ------------------ */
1603/* MACETAT */
1604
1605/* REFERENCES APPELEES : */
1606/* --------------------- */
1607/* NEANT */
1608
1609/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1610/* ----------------------------------- */
1611/* DROIT D'UTILISATION : TOUTES APPLICATIONS */
1612
1613/* ATTENTION : CETTE ROUTINE DEPEND D'UNE INITIALISATION */
1614/* ---------- PREALABLE FAITE AVEC AMDGEN. */
1615/* IL CONVIENT DONC DE S'ASSURER QUE CETTE INIT EST */
1616/* BIEN REALISEE DANS LE OU LES PROGRAMMES CONCERNES */
1617
1618/* $ HISTORIQUE DES MODIFICATIONS : */
1619/* ------------------------------ */
1620/* 25-01-93 : JMB ; NETTOYAGE DE MAMDLNG */
1621/* 23-03-90 : DGZ ; CORRECTION DE L'EN-TETE */
1622/* 22-12-89 : DGZ ; CORRECTION DE L'EN-TETE */
1623/* 22-02-88 : DGZ ; CREATION VERSION ORIGINALE */
1624/* > */
1625/* ***********************************************************************
1626 */
1627
1628
1629/* INCLUDE MACETAT */
1630/* < */
1631
1632/* ***********************************************************************
1633 */
1634
1635/* FONCTION : */
1636/* ---------- */
1637/* CONTIENT LES INFORMATIONS RELATIVES A LA COMPOSITION DE */
1638/* L'EXECUTABLE ET A SON ENVIRONNEMENT : */
1639/* - LANGUES */
1640/* - APPLICATIONS PRESENTES */
1641/* - TYPES D'ENTITES AUORISEES (NON UTILISE) */
1642/* AINSI QUE DES INFORMATIONS DECRIVANTS L'ETAT COURANT : */
1643/* - APPLICATION EN COURS */
1644/* - MODE D'UTILISATION (NON UTILISE) */
1645
1646/* MOTS CLES : */
1647/* ----------- */
1648/* APPLICATION, LANGUE */
1649
1650/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
1651/* ----------------------------------- */
1652
1653/* A) CHLANG*4 : LISTE DES VALEURS POSSIBLES DE LA LANGUE : */
1654/* 'FRA ','DEU ','ENG ' */
1655
1656/* CHL10N*4 : LISTE DES VALEURS POSSIBLES DE LA LOCALISATION : */
1657/* 'FRA ','DEU ','ENG ', 'JIS ' */
1658
1659/* B) CHCOUR*4, CHPREC*4, CHSUIV*4 : APPLICATION COURANTE, PRECEDENTE
1660*/
1661/* ET SUIVANTE */
1662
1663/* C) CHMODE*4 : MODE COURANT (NON UTILISE) */
1664
1665/* D) CHPRES*2 (1:NBRMOD) : LISTE DES APPLICATIONS PRISES EN COMPTE */
1666
1667/* Rang ! Code interne ! Application */
1668/* ---------------------------------------------------------- */
1669/* 1 ! CD ! Modelisation 2D */
1670/* 2 ! CA ! Modelisation 2D par apprentissage */
1671/* 3 ! CP ! Modelisation 2D parametree */
1672/* 4 ! PC ! Modelisation rheologique 2D */
1673/* 5 ! CU ! Fraisage 2 Axes 1/2 */
1674/* 6 ! CT ! Tournage */
1675/* 7 ! TS ! Modelisation 3D surfacique */
1676/* 8 ! TV ! Modelisation 3D volumique */
1677/* 9 ! MC ! Maillage coque */
1678/* 10 ! MV ! Maillage volumique */
1679/* 11 ! TU ! Usinage 3 axes continus */
1680/* 12 ! T5 ! Usinage 3-5 axes */
1681/* 13 ! TR ! Usinage 5 axes de surfaces reglees */
1682/* 14 ! IG ! Interface IGES */
1683/* 15 ! ST ! Interface SET */
1684/* 16 ! VD ! Interface VDA */
1685/* 17 ! IM ! Interface de modelisation */
1686/* 18 ! GA ! Generateur APT/IFAPT */
1687/* 19 ! GC ! Generateur COMPACT II */
1688/* 20 ! GP ! Generateur PROMO */
1689/* 21 ! TN ! Usinage par copiage numerique */
1690/* 22 ! GM ! Gestion des modeles */
1691/* 23 ! GT ! Gestion de trace */
1692/* ---------------------------------------------------------- */
1693
1694
1695/* $ HISTORIQUE DES MODIFICATIONS : */
1696/* ------------------------------ */
1697/* 05-05-93 : JMB ; Livraison GI93033FGR019 */
1698/* 8-03-1993: STT ; AJOUT CHL10N */
1699/* 31-07-92 : FCR ; GI91050G0348 : Suppression de CHTYPE */
1700/* 18-06-90 : DGZ ; AJOUT EXTENSION PAR COPIAGE NUMERIQUE */
1701/* 15-03-89 : DGZ ; MODIF DES APPLICATIONS POUR STANDARDS METIERS
1702*/
1703/* 13-09-88 : DGZ ; AJOUT DES MODULES CC (TVCC) ET CG (CA GLOBAL)
1704*/
1705/* 13-09-88 : DGZ ; AJOUT DES MODULES SET, IGES, VDA */
1706/* 22-02-88 : DGZ ; CREATION VERSION ORIGINALE */
1707/* > */
1708/* ***********************************************************************
1709 */
1710
1711/* NOMBRE D'APPLICATIONS PRISES EN COMPTE */
1712
1713
1714/* NOMBRES DE TYPES D'ENTITE GERES PAR STRIM 100 */
1715 //__s__copy(cmdlng, macetat_.chlang, cmdlng_len, 4L);
1716
1717 return 0 ;
1718} /* mamdlng_ */
1719
1720//=======================================================================
1721//function : maostrb_
1722//purpose :
1723//=======================================================================
1724int maostrb_()
1725{
1726 return 0 ;
1727} /* maostrb_ */
1728
1729//=======================================================================
1730//function : maostrd_
1731//purpose :
1732//=======================================================================
1733int maostrd_()
1734{
1735 static integer imod;
1736
1737/* ***********************************************************************
1738 */
1739
1740/* FONCTION : */
1741/* ---------- */
1742/* AFFICHAGE DU TRACE-BACK EN PHASE DE PRODUCTION */
1743
1744/* MOTS CLES : */
1745/* ----------- */
1746/* FONCTION, SYSTEME, TRACE-BACK, AFFICHAGE, DEBUGGAGE */
1747
1748/* ARGUMENTS D'ENTREE : */
1749/* -------------------- */
1750/* NEANT */
1751
1752/* ARGUMENTS DE SORTIE : */
1753/* --------------------- */
1754/* NEANT */
1755
1756/* COMMONS UTILISES : */
1757/* ------------------ */
1758/* NEANT */
1759
1760/* REFERENCES APPELEES : */
1761/* --------------------- */
1762/* MADBTBK */
1763
1764/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1765/* ----------------------------------- */
1766/* CETTE ROUTINE DOIT ETRE APPELE POUR REALISER UN AFFICHAGE */
1767/* DE TRACE-BACK EN PHASE DE PRODUCTION ET LAISSER QUAND MEME */
1768/* LA POSSIBILITE AUX TESTEURS D'OBTENIR CES TRACE-BACK DANS */
1769/* LES VERSIONS CLIENTS SI UNE DES CONTIONS SUIVANTES EST */
1770/* VERIFIEE : */
1771/* - EXISTENCE DU SYMBOLE 'STRMTRBK' */
1772/* - EXISTENCE DU FICHIER 'STRMINIT:STRMTRBK.DAT' */
1773
1774/* $ HISTORIQUE DES MODIFICATIONS : */
1775/* ------------------------------ */
1776/* 26-07-90 : DGZ ; CREATION DE LA VERSION ORIGINALE */
1777/* > */
1778/* ***********************************************************************
1779 */
1780 madbtbk_(&imod);
1781 if (imod == 1) {
1782 maostrb_();
1783 }
1784 return 0 ;
1785} /* maostrd_ */
1786
1787//=======================================================================
1788//function : maoverf_
1789//purpose :
1790//=======================================================================
1791int maoverf_(integer *nbentr,
1792 doublereal *dtable)
1793
1794{
1795 /* Initialized data */
1796
1797 static integer ifois = 0;
1798
1799 /* System generated locals */
1800 integer i__1;
1801
1802 /* Local variables */
1803 static integer ibid;
1804 static doublereal buff[63];
1805 static integer ioct, indic, nrest, icompt;
1806
1807/* ***********************************************************************
1808 */
1809
1810/* FONCTION : */
1811/* ---------- */
1812/* Initialisation en overflow d'un tableau en DOUBLE PRECISION */
1813
1814/* MOTS CLES : */
1815/* ----------- */
1816/* MANIPULATION, MEMOIRE, INITIALISATION, OVERFLOW */
1817
1818/* ARGUMENTS D'ENTREE : */
1819/* -------------------- */
1820/* NBENTR : Nombre d'entrees du tableau */
1821
1822/* ARGUMENTS DE SORTIE : */
1823/* --------------------- */
1824/* DATBLE : Tableau double precision initialise en overflow */
1825
1826/* COMMONS UTILISES : */
1827/* ------------------ */
1828/* R8OVR contenu dans l'include MAOVPAR.INC */
1829
1830/* REFERENCES APPELEES : */
1831/* --------------------- */
1832/* MCRFILL */
1833
1834/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1835/* ----------------------------------- */
1836/* 1) Doc. programmeur : */
1837
1838/* Cette routine initialise a l'overflow positif un tableau en */
1839/* DOUBLE PRECISION. */
1840
1841/* Les autres types de tableaux (INTEGER*2, INTEGER, REAL, ...) */
1842/* ne sont pas geres par la routine. */
1843
1844/* Elle est utilisable en phase de developpement pour deceler les */
1845/* erreurs d'initialisation. */
1846
1847/* En version officielle, ses appels seront desactives. */
1848
1849/* ACCES : Sur accord avec AC. */
1850
1851/* La routine ne renvoie pas de code d'erreur. */
1852
1853/* L'argument NBELEM doit etre positif. */
1854/* S'il est negatif ou nul, affichage du message "MAOVERF : NBELEM =
1855 */
1856/* valeur_de_NBELEM" et d'un Trace Back par l'appel a la routine */
1857/* MAOSTRB. */
1858
1859
1860/* 2) Doc. concepteur : */
1861
1862/* L'idee est de minimiser le nombre d'appels a */
1863/* la routine de transfert de zones numeriques, */
1864/* ---------- pour des raisons de performances. */
1865/* ! buffer ! Pour cela, on se reserve un tableau de NLONGR */
1866/* !__________! DOUBLE PRECISIONs. Ce buffer est initialise par */
1867/* <----------> l'instruction DATA. L'overflow est accede dans un */
1868/* NLONGR*8 COMMON specifique et non par une routine car */
1869/* l'initialisation se fait par DATA. */
1870
1871/* * Si NBENTR<NLONGR, une partie du buffer est transferee
1872*/
1873/* DTABLE dans DTABLE. */
1874/* __________ */
1875/* ! amorce ! * Sinon, tout le buffer est transfere dans DTABLE. */
1876/* !__________! C'est l'amorce. Puis on execute une boucle qui a chaque
1877*/
1878/* ! temps 1 ! iteration transfere la partie du tableau deja */
1879/* !__________! initialisee dans celle qui ne l'a pas encore ete. La */
1880/* ! ! taille de la zone transferee par chaque appel a MCRFILL
1881*/
1882/* ! temps 2 ! est donc de NLONGR*2**(numero_de_l'iteration). Lorsque
1883*/
1884/* ! ! la taille du tableau restant a initialiser est */
1885/* !__________! inferieure a celle deja initialisee, on sort de la */
1886/* ! ! boucle et un dernier transfert est effectue pour */
1887/* ! ! initialiser le reste du tableau, sauf si la taille */
1888/* ! ! du tableau est du type NLONGR*2**K. */
1889/* ! temps 3 ! */
1890/* ! ! * NLONGR sera egal a 19200. */
1891/* ! ! */
1892/* ! ! */
1893/* !__________! */
1894/* ! reste ! */
1895/* !__________! */
1896
1897/* $ HISTORIQUE DES MODIFICATIONS : */
1898/* ------------------------------ */
1899/* 05-03-93 : JMB ; Prise en compte MAOVPAR non specifique */
1900/* 02-10-91 : DGZ ; Reprise et livraison */
1901/* 17-08-90 : EVT ; Creation version originale. */
1902/* > */
1903/* ***********************************************************************
1904 */
1905
1906/* Inclusion de MAOVPAR.INC */
1907
1908/* CONSTANTES */
1909/* INCLUDE MAOVPAR */
1910/* ***********************************************************************
1911 */
1912
1913/* FONCTION : */
1914/* ---------- */
1915/* DEFINIT LES VALEURS LIMITES SPECIFIQUES MACHINE. */
1916
1917/* MOTS CLES : */
1918/* ----------- */
1919/* SYSTEME, LIMITES, VALEURS, SPECIFIQUE */
1920
1921/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
1922/* ----------------------------------- */
1923/* *** ELLES NE PEUVENT PAS ETRE ECRASEES EN COURS D'EXECUTION. */
1924
1925/* *** LES VALEURS D'UNDERFLOW ET D'OVERFLOW NE PEUVENT PAS ETRE */
1926/* DEFINIES EN VALEUR DECIMALES (ERREUR A LA COMPILATION D_FLOAT) */
1927/* ON LES DEFINIT DONC EN VALEUR HEXADECIMALES */
1928
1929/* $ HISTORIQUE DES MODIFICATIONS : */
1930/* ------------------------------ */
1931/* 02-02-1993 : JMB ; SUPPRESSION DE LA SPECIFICITE DE L'INCLUDE */
1932/* 29-08-1990 : DGZ ; AJOUT DES REELS X4OVR ET X4UND */
1933/* 10-08-1990 : DGZ ; AJOUT DES FORMATS FRMR4,FRMR8,FRMR8G */
1934/* 18-06-1990 : CS/DGZ ; CREATION VERSION ORIGINALE */
1935/* > */
1936/* ***********************************************************************
1937 */
1938
1939
1940/* DECLARATION DU COMMON POUR LES TYPES NUMERIQUES */
1941
1942
1943/* DECLARATION DU COMMON POUR LES TYPES CARACTERES */
1944
1945
1946
1947/* VARIABLES LOCALES */
1948
1949/* TABLEAUX */
1950
1951/* DATAS */
1952 /* Parameter adjustments */
1953 --dtable;
1954
1955 /* Function Body */
1956
1957 /* vJMB R8OVR n est pas encore initialise, donc impossible d utiliser DATA
1958 */
1959 /* DATA BUFF / NLONGR * R8OVR / */
1960
1961 /* l init de BUFF n est faite qu'une fois */
1962
1963 if (ifois == 0) {
1964 for (icompt = 1; icompt <= 63; ++icompt) {
1965 buff[icompt - 1] = maovpar_.r8ovr;
1966 /* L20: */
1967 }
1968 ifois = 1;
1969 }
1970
1971 /* ^JMB */
1972 /* Exception */
1973 if (*nbentr < 63) {
1974 nrest = *nbentr << 3;
1975 AdvApp2Var_SysBase::mcrfill_(&nrest, (char *)buff, (char *)&dtable[1]);
1976 } else {
1977
1978 /* Amorce & initialisations */
1979 ioct = 504;
1980 AdvApp2Var_SysBase::mcrfill_(&ioct, (char *)buff, (char *)&dtable[1]);
1981 indic = 63;
1982
1983 /* Boucle. La borne sup. est la valeur entiere du logarithme de base 2
1984 */
1985 /* de NBENTR/NLONGR. */
1986 i__1 = (integer) (log((real) (*nbentr) / (float)63.) / log((float)2.))
1987 ;
1988 for (ibid = 1; ibid <= i__1; ++ibid) {
1989
1990 AdvApp2Var_SysBase::mcrfill_(&ioct, (char *)&dtable[1], (char *)&dtable[indic + 1]);
1991 ioct += ioct;
1992 indic += indic;
1993
1994 /* L10: */
1995 }
1996
1997 nrest = ( *nbentr - indic ) << 3;
1998
1999 if (nrest > 0) {
2000 AdvApp2Var_SysBase::mcrfill_(&nrest, (char *)&dtable[1], (char *)&dtable[indic + 1]);
2001 }
2002
2003 }
2004 return 0 ;
2005} /* maoverf_ */
2006
2007//=======================================================================
2008//function : AdvApp2Var_SysBase::maovsr8_
2009//purpose :
2010//=======================================================================
2011int AdvApp2Var_SysBase::maovsr8_(integer *ivalcs)
2012{
2013 *ivalcs = maovpar_.r8ncs;
2014 return 0 ;
2015} /* maovsr8_ */
2016
2017//=======================================================================
2018//function : matrlog_
2019//purpose :
2020//=======================================================================
2021int matrlog_(const char *,//cnmlog,
2022 const char *,//chaine,
2023 integer *length,
2024 integer *iercod,
2025 ftnlen ,//cnmlog_len,
2026 ftnlen )//chaine_len)
2027
2028{
2029 *iercod = 1;
2030 *length = 0;
2031
2032 return 0 ;
2033} /* matrlog_ */
2034
2035//=======================================================================
2036//function : matrsym_
2037//purpose :
2038//=======================================================================
2039int matrsym_(const char *cnmsym,
2040 const char *,//chaine,
2041 integer *length,
2042 integer *iercod,
2043 ftnlen cnmsym_len,
2044 ftnlen )//chaine_len)
2045
2046{
2047 /* Local variables */
2048 static char chainx[255];
2049
2050/* ***********************************************************************
2051 */
2052
2053/* FONCTION : */
2054/* ---------- */
2055/* RECUPERE LA VALEUR D'UN SYMBOLE DEFINI AU MOMENT DE */
2056/* L'INITIALISATION D'UN UTILISATEUR */
2057
2058/* MOTS CLES : */
2059/* ----------- */
2060/* TRADUCTION, SYMBOLE */
2061
2062/* ARGUMENTS D'ENTREE : */
2063/* -------------------- */
2064/* CNMSYM : NOM DU SYMBOLE */
2065
2066/* ARGUMENTS DE SORTIE : */
2067/* --------------------- */
2068/* CHAINE : TRADUCTION DU SYMBOLE */
2069/* LENGTH : LONGUEUR UTILE DE LA CHAINE */
2070/* IERCOD : CODE D'ERREUR */
2071/* = 0 : OK */
2072/* = 1 : SYMBOLE INEXISTANT */
2073/* = 2 : AUTRE ERREUR */
2074
2075/* COMMONS UTILISES : */
2076/* ------------------ */
2077/* NEANT */
2078
2079/* REFERENCES APPELEES : */
2080/* --------------------- */
2081/* LIB$GET_SYMBOL,MACHDIM */
2082
2083/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2084/* ----------------------------------- */
2085/* - CETTE ROUTINE EST SPECIFIQUE VAX */
2086/* - EN CAS D'ERREUR (IERCOD>0), CHAINE = ' ' ET LENGTH = 0 */
2087/* - SI LA VARIABLE D'ENTREE CNMSYM EST VIDE, LA ROUTINE RENVOIE IERC
2088OD=1*/
2089
2090/* $ HISTORIQUE DES MODIFICATIONS : */
2091/* ------------------------------ */
2092/* SGI_H 16-04-91 : CSO ; CORRECTION CAS SYMBOLE INEXISTANT ==> IERCOD=1
2093*/
2094/* SGI_ 07-01-91 : SVN ; MODIF IERCOD NE DOIT PAS DEPASSER 2 */
2095/* CHAINEVIDE VAUT CARACTERE BLANC */
2096/* 22-02-88 : DGZ ; CREATION DE LA VERSION ORIGINALE */
2097/* 07-09-88 : SGI_H : CS; SOUS UNIX SYMBOLE=NOM LOGIQUE = VARIABLE
2098*/
2099/* ==> idem MAGTLOG */
2100/* > */
2101/* ***********************************************************************
2102 */
2103
2104
2105/* SGI...v */
2106
2107 /* SGI CALL MAGTLOG (CNMSYM,CHAINE,LENGTH,IERCOD) */
2108 magtlog_(cnmsym, chainx, length, iercod, cnmsym_len, 255L);
2109 /* SO...v */
2110 if (*iercod == 5) {
2111 *iercod = 1;
2112 }
2113 /* SO...^ */
2114 if (*iercod >= 2) {
2115 *iercod = 2;
2116 }
2117 //if (__s__cmp(chainx, "NONE", 255L, 4L) == 0) {
2118 if (__s__cmp() == 0) {
2119 //__s__copy(chainx, " ", 255L, 1L);
2120 *length = 0;
2121 }
2122 //__s__copy(chaine, chainx, chaine_len, 255L);
2123 /* SGI...^ */
2124
2125
2126 /* ***********************************************************************
2127 */
2128 /* TRAITEMENT DES ERREURS */
2129 /* ***********************************************************************
2130 */
2131
2132
2133 /* L9999: */
2134 return 0;
2135} /* matrsym_ */
2136
2137//=======================================================================
2138//function : mcrcomm_
2139//purpose :
2140//=======================================================================
2141int mcrcomm_(integer *kop,
2142 integer *noct,
2143 long int *iadr,
2144 integer *ier)
2145
2146{
2147 /* Initialized data */
2148
2149 static integer ntab = 0;
2150
2151 /* System generated locals */
2152 integer i__1, i__2;
2153
2154 /* Local variables */
2155 static integer ideb;
2156 static doublereal dtab[32000];
2157 static long int itab[160] /* was [4][40] */;
2158 static integer ipre, i__, j, k;
2159
2160
2161/************************************************************************
2162*******/
2163
2164/* FONCTION : */
2165/* ---------- */
2166/* ALLOCATION DYNAMIQUE SUR COMMON */
2167
2168/* MOTS CLES : */
2169/* ----------- */
2170/* . ALLOCDYNAMIQUE,MEMOIRE,COMMON,ALLOC */
2171
2172/* ARGUMENTS D'ENTREE : */
2173/* ------------------ */
2174/* KOP : (1,2) = (ALLOCATION,DESTRUCTION) */
2175/* NOCT : NOMBRE D'OCTETS */
2176
2177/* ARGUMENTS DE SORTIE : */
2178/* ------------------- */
2179/* IADR : ADRESSE EN MEMOIRE DU PREMIER OCTET */
2180/* * : */
2181/* * : */
2182/* IERCOD : CODE D'ERREUR */
2183
2184/* IERCOD = 0 : OK */
2185/* IERCOD > 0 : ERREUR GRAVE */
2186/* IERCOD < 0 : WARNING */
2187/* IERCOD = 1 : DESCRIPTION DE L'ERREUR */
2188/* IERCOD = 2 : DESCRIPTION DE L'ERREUR */
2189
2190/* COMMONS UTILISES : */
2191/* ---------------- */
2192
2193/* CRGEN2 */
2194
2195/* REFERENCES APPELEES : */
2196/* ---------------------- */
2197
2198/* Type Name */
2199/* MCRLOCV */
2200
2201/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2202/* ----------------------------------- */
2203
2204/* ATTENTION .... ITAB ET NTAB NE SONT PAS SAUVEGARDES ENTRE 2 APPELS..
2205*/
2206
2207/* $ HISTORIQUE DES MODIFICATIONS : */
2208/* -------------------------------- */
2209/* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS. */
2210/* 16-05-89 : DGZ; SUPPRESSION DU COMMON CRGEN2 */
2211/* 02-05-88 : PP ; AJOUT DE COMMENTAIRES */
2212/* 20-01-88 : JPF; MAXCOM DE 500 --> 250 */
2213/* 09-12-85 : BF ; UTILISE LES ROUTINES STANDARDS */
2214/* 08-11-85 : BF ; BUG SUR DEPLACEMENT TROU */
2215/* 07-11-85 : BF ; VERSION D'ORIGINE */
2216
2217/* > */
2218/* ***********************************************************************
2219 */
2220
2221/* JPF PARAMETER ( MAXNUM = 40 , MAXCOM = 500 * 1024 ) */
2222
2223/* ITAB : TABLE DE GESTION DE DTAB, ZONE DE MEMOIRE ALLOUABLE . */
2224/* NTAB : NOMBRE D'ALLOCS REALISEES . */
2225/* FORMAT DE ITAB : NOMBRE DE REAL*8 ALLOUES , ADRESSE DU 1ER REAL*8
2226*/
2227/* , NOCT , ADRESSE VIRTUELLE */
2228
2229/* PP COMMON / CRGEN2 / DTAB */
2230
2231
2232/* ----------------------------------------------------------------------*
2233 */
2234
2235 *ier = 0;
2236
2237 /* ALLOCATION : RECHERCHE D'UN TROU */
2238
2239 if (*kop == 1) {
2240 *iadr = 0;
2241 if (*noct < 1) {
2242 *ier = 1;
2243 goto L9900;
2244 }
2245 if (ntab >= 40) {
2246 *ier = 2;
2247 goto L9900;
2248 }
2249
2250 i__1 = ntab + 1;
2251 for (i__ = 1; i__ <= i__1; ++i__) {
2252 if (i__ <= 1) {
2253 ipre = 1;
2254 } else {
2255 ipre = itab[((i__ - 1) << 2) - 3] + itab[((i__ - 1) << 2) - 4];
2256 }
2257 if (i__ <= ntab) {
2258 ideb = itab[(i__ << 2) - 3];
2259 } else {
2260 ideb = 32001;
2261 }
2262 if ((ideb - ipre) << 3 >= *noct) {
2263 /* ON A TROUVE UN TROU */
2264 i__2 = i__;
2265 for (j = ntab; j >= i__2; --j) {
2266 for (k = 1; k <= 4; ++k) {
2267 itab[k + ((j + 1) << 2) - 5] = itab[k + (j << 2) - 5];
2268 /* L1003: */
2269 }
2270 /* L1002: */
2271 }
2272 ++ntab;
2273 itab[(i__ << 2) - 4] = *noct / 8 + 1;
2274 itab[(i__ << 2) - 3] = ipre;
2275 itab[(i__ << 2) - 2] = *noct;
2276 mcrlocv_((long int)&dtab[ipre - 1], (long int *)iadr);
2277 itab[(i__ << 2) - 1] = *iadr;
2278 goto L9900;
2279 }
2280 /* L1001: */
2281 }
2282
2283 /* PAS DE TROU */
2284
2285 *ier = 3;
2286 goto L9900;
2287
2288 /* ----------------------------------- */
2289 /* DESTRUCTION DE L'ALLOCATION NUM : */
2290
2291 } else {
2292 i__1 = ntab;
2293 for (i__ = 1; i__ <= i__1; ++i__) {
2294 if (*noct != itab[(i__ << 2) - 2]) {
2295 goto L2001;
2296 }
2297 if (*iadr != itab[(i__ << 2) - 1]) {
2298 goto L2001;
2299 }
2300 /* ON A TROUVE L'ALLOCATION A SUPPRIMER */
2301 i__2 = ntab;
2302 for (j = i__ + 1; j <= i__2; ++j) {
2303 for (k = 1; k <= 4; ++k) {
2304 itab[k + ((j - 1) << 2) - 5] = itab[k + (j << 2) - 5];
2305 /* L2003: */
2306 }
2307 /* L2002: */
2308 }
2309 --ntab;
2310 goto L9900;
2311 L2001:
2312 ;
2313 }
2314
2315 /* L'ALLOCATION N'EXISTE PAS */
2316
2317 *ier = 4;
2318 /* PP GOTO 9900 */
2319 }
2320
2321 L9900:
2322 return 0;
2323} /* mcrcomm_ */
2324
2325//=======================================================================
2326//function : AdvApp2Var_SysBase::mcrdelt_
2327//purpose :
2328//=======================================================================
2329int AdvApp2Var_SysBase::mcrdelt_(integer *iunit,
2330 integer *isize,
2331 doublereal *t,
2332 long int *iofset,
2333 integer *iercod)
2334
2335{
2336 static integer ibid;
2337 static doublereal xbid;
2338 static integer noct, iver, ksys, i__, n, nrang,
2339 ibyte, ier;
2340 static long int iadfd, iadff, iaddr, loc; /* Les adrresses en long*/
2341 static integer kop;
2342
2343/* ***********************************************************************
2344 */
2345
2346/* FONCTION : */
2347/* ---------- */
2348/* DESTRUCTION D'UNE ALLOCATION DYNAMIQUE */
2349
2350/* MOTS CLES : */
2351/* ----------- */
2352/* SYSTEME, ALLOCATION, MEMOIRE, DESTRUCTION */
2353
2354/* ARGUMENTS D'ENTREE : */
2355/* ------------------ */
2356/* IUNIT : NOMBRE D'OCTETS DE L'UNITE D'ALLOCATION */
2357/* ISIZE : NOMBRE D'UNITES DEMANDEES */
2358/* T : ADRESSE DE REFERENCE */
2359/* IOFSET : DECALAGE */
2360
2361/* ARGUMENTS DE SORTIE : */
2362/* ------------------- */
2363/* IERCOD : CODE D'ERREUR */
2364/* = 0 : OK */
2365/* = 1 : PB DE DE-ALLOCATION D'UNE ZONE ALLOUEE EN COMMON */
2366/* = 2 : LE SYSTEME REFUSE LA DEMANDE DE DE-ALLOCATION */
2367/* = 3 : L'ALLOCATION A DETRUIRE N'EXISTE PAS. */
2368
2369/* COMMONS UTILISES : */
2370/* ---------------- */
2371
2372
2373/* REFERENCES APPELEES : */
2374/* ---------------------- */
2375
2376
2377/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2378/* ----------------------------------- */
2379
2380/* 1) UTILISATEUR */
2381/* ----------- */
2382
2383/* MCRDELT FAIT UNE LIBERATION DE ZONE MEMOIRE ALLOUEE */
2384/* PAR LA ROUTINE MCRRQST (OU CRINCR) */
2385
2386/* LA SIGNIFICATION DES ARGUMENTS EST LA MEME QUE MCRRQST */
2387
2388/* *** ATTENTION : */
2389/* ----------- */
2390/* IERCOD=2 : CAS OU LE SYSTEME NE PEUT LIBERER LA MEMOIRE ALLOUEE, */
2391/* LE MESSAGE SUIVANT APPARAIT SYSTEMATIQUEMENT SUR LA CONSOLE */
2392/* ALPHA : */
2393/* "Le systeme refuse une destruction d'allocation de memoire" */
2394
2395/* IERCOD=3 CORRESPOND AU CAS OU LES ARGUMENTS SONT MAUVAIS */
2396/* (ILS NE PERMETTENT PAS DE RECONNAITRE L'ALLOCATION DANS LA TABLE)
2397*/
2398
2399/* Lorsque l'allocation est detruite, l'IOFSET correspondant est mis
2400*/
2401/* a 2 147 483 647. Ainsi, si on accede au tableau via l'IOFSET, un */
2402/* trap se produira. Ceci permet de verifier qu'on ne se sert plus */
2403/* d'une zone de memoire qu'on a liberee. Cette verification n'est */
2404/* valable que si c'est le meme sous-programme qui utilise et qui */
2405/* detruit l'allocation. */
2406
2407/* $ HISTORIQUE DES MODIFICATIONS : */
2408/* -------------------------------- */
2409/* 05-03-93 : FCR : DMSF52088 : On prend les memes et on recommence ...
2410*/
2411/* IERCOD = 3 et I4UND. */
2412/* 22-02-93 : FCR : Pour TOYOTA : Desactivation de l'affectation de */
2413/* l'IOFSET a I4UND et suppression de IERCOD = 3. */
2414/* 10-02-93 : FCR ; DMSFRO253 : Ajout d'un appel a MAERMSG si IERCOD
2415*/
2416/* = 3 */
2417/* 22-01-93 : FCR ; DMSF52088 : Ajout de l'IERCOD 3. */
2418/* Ajout de l'IOFSET mis a I4UND lorsque */
2419/* l'allocation est detruite. */
2420/* 08-10-92 : FCR ; DMSFRO131 : Modif pour DEBUG-ALLOC */
2421/* 08-09-92 : FCR ; Optimisation */
2422/* 18-11-91 : DGZ ; APPEL MACRCHK EN PHASE DE DEVELOPPEMENT */
2423/* 23-09-91 : DGZ ; RENOMME EN .FOR ET MODIFS DE COMMENTAIRES */
2424/* 14-05-91 : DGZ ; SUPPRIME L'OPTION /CHECK=NBOUNDS */
2425/* 21-08-90 : DGZ ; AFFICHAGE DU TRACE-BACK EN PHASE DE PRODUCTION */
2426/* ET RENOMME EN .VAX */
2427/* 22-12-89 : DGZ ; CORRECTION DE L'EN-TETE */
2428/* 04-11-89 : CR ; AJOUT DE OPTIONS /CHECK=NOBOUNDS. */
2429/* 11-05-89 : DGZ; CONTROLE DEBORDEMENT DE MEMOIRE */
2430/* 27-06-88 : PP ; VIRE 9001 INUTILISE */
2431/* PP 26.2.88 CHANGE LE VFORMA EN MACRMSG, POUR USAGE DANS C */
2432/* 09-01-87 : BF ; ALLOCATIONS SYSTEME */
2433/* 03-11-86 : BF ; RAJOUTE STATISTIQUES */
2434/* 09-12-85 : BF ; UTILISE LES ROUTINES STANDARDS */
2435/* 09-12-85 : BF ; PLUS D'ERREUR SI L'ALLOCATION N'EXISTE PAS */
2436/* 07-11-85 : BF ; VERSION D'ORIGINE */
2437/* > */
2438/* ***********************************************************************
2439 */
2440
2441/* COMMON DES PARAMETRES */
2442
2443/* COMMON DES STATISTIQUES */
2444/* INCLUDE MCRGENE */
2445
2446/* ***********************************************************************
2447 */
2448
2449/* FONCTION : */
2450/* ---------- */
2451/* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */
2452
2453/* MOTS CLES : */
2454/* ----------- */
2455/* SYSTEME, MEMOIRE, ALLOCATION */
2456
2457/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
2458/* ----------------------------------- */
2459
2460/* $ HISTORIQUE DES MODIFICATIONS : */
2461/* ------------------------------ */
2462/* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */
2463/* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
2464/* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */
2465/* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */
2466/* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */
2467/* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */
2468/* + AJOUT DE COMMENTAIRES */
2469/* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */
2470/* 15-04-85 : BF ; VERSION D'ORIGINE */
2471/* > */
2472/* ***********************************************************************
2473 */
2474
2475/* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */
2476/* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */
2477/* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */
2478/* 2 : UNITE D'ALLOCATION */
2479/* 3 : NB D'UNITES ALLOUEES */
2480/* 4 : ADRESSE DE REFERENCE DU TABLEAU */
2481/* 5 : IOFSET */
2482/* 6 : NUMERO ALLOCATION STATIQUE */
2483/* 7 : Taille demandee en allocation */
2484/* 8 : adresse du debut de l'allocation */
2485/* 9 : Taille de la ZONE UTILISATEUR */
2486/* 10 : ADRESSE DU FLAG DE DEBUT */
2487/* 11 : ADRESSE DU FLAG DE FIN */
2488/* 12 : Rang de creation de l'allocation */
2489
2490/* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */
2491/* NCORE : NBRE D'ALLOCS EN COURS */
2492/* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST
2493*/
2494/* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */
2495
2496
2497
2498/* ----------------------------------------------------------------------*
2499 */
2500
2501
2502/* 20-10-86 : BF ; VERSION D'ORIGINE */
2503
2504
2505/* NRQST : NOMBRE D'ALLOCATIONS EFFECTUEES */
2506/* NDELT : NOMBRE DE LIBERATIONS EFFECTUEES */
2507/* NBYTE : NOMBRE TOTAL D'OCTETS DES ALLOCATIONS */
2508/* MBYTE : NOMBRE MAXI D'OCTETS */
2509
2510 /* Parameter adjustments */
2511 --t;
2512
2513 /* Function Body */
2514 *iercod = 0;
2515
2516/* RECHERCHE DANS MCRGENE */
2517
2518 n = 0;
2519 mcrlocv_((long int)&t[1], (long int *)&loc);
2520
2521 for (i__ = mcrgene_.ncore; i__ >= 1; --i__) {
2522 if (*iunit == mcrgene_.icore[i__ * 12 - 11] && *isize ==
2523 mcrgene_.icore[i__ * 12 - 10] && loc == mcrgene_.icore[i__ *
2524 12 - 9] && *iofset == mcrgene_.icore[i__ * 12 - 8]) {
2525 n = i__;
2526 goto L1100;
2527 }
2528/* L1001: */
2529 }
2530L1100:
2531
2532/* SI L'ALLOCATION N'EXISTE PAS , ON SORT */
2533
2534 if (n <= 0) {
2535 goto L9003;
2536 }
2537
2538/* ALLOCATION RECONNUE : ON RECUPERE LES AUTRES INFOS */
2539
2540 ksys = mcrgene_.icore[n * 12 - 7];
2541 ibyte = mcrgene_.icore[n * 12 - 6];
2542 iaddr = mcrgene_.icore[n * 12 - 5];
2543 iadfd = mcrgene_.icore[n * 12 - 3];
2544 iadff = mcrgene_.icore[n * 12 - 2];
2545 nrang = mcrgene_.icore[n * 12 - 1];
2546
2547/* Controle des flags */
2548
2549 madbtbk_(&iver);
2550 if (iver == 1) {
2551 macrchk_();
2552 }
2553
2554 if (ksys <= 1) {
2555/* DE-ALLOCATION SUR COMMON */
2556 kop = 2;
2557 mcrcomm_(&kop, &ibyte, &iaddr, &ier);
2558 if (ier != 0) {
2559 goto L9001;
2560 }
2561 } else {
2562/* DE-ALLOCATION SYSTEME */
2563 mcrfree_((integer *)&ibyte, (uinteger *)&iaddr, (integer *)&ier);
2564 if (ier != 0) {
2565 goto L9002;
2566 }
2567 }
2568
2569/* APPEL PERMETTANT LE CANCEL WATCH AUTOMATQUE PAR LE DEBUGGER */
2570
2571 macrclw_(&iadfd, &iadff, &nrang);
2572
2573/* MISE A JOUR DES STATISTIQUES */
2574 if (ksys <= 1) {
2575 i__ = 1;
2576 } else {
2577 i__ = 2;
2578 }
2579 ++mcrstac_.ndelt[i__ - 1];
2580 mcrstac_.nbyte[i__ - 1] -= mcrgene_.icore[n * 12 - 11] *
2581 mcrgene_.icore[n * 12 - 10];
2582
2583/* SUPPRESSION DES PARAMETRES DANS MCRGENE */
2584 if (n < 1000) {
2585/* noct = (mcrgene_1.ncore - n) * 48; */
2586 noct = (mcrgene_.ncore - n) * 12 * sizeof(long int);
2587 AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
2588 (char *)&mcrgene_.icore[(n + 1) * 12 - 12],
2589 (char *)&mcrgene_.icore[n * 12 - 12]);
2590 }
2591 --mcrgene_.ncore;
2592
2593/* *** Mise a l'overflow de l'IOFSET */
2594 *iofset = 2147483647;
2595 goto L9900;
2596
2597/* ----------------------------------------------------------------------*
2598 */
2599/* TRAITEMENT DES ERREURS */
2600
2601L9001:
2602/* REFUS DE DE-ALLOCATION PAR LA ROUTINE 'MCRCOMM' (ALLOC DS COMMON) */
2603 *iercod = 1;
2604 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2605 maostrd_();
2606 goto L9900;
2607
2608/* REFUS DE DE-ALLOCATION PAR LE SYSTEME */
2609L9002:
2610 *iercod = 2;
2611 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2612 macrmsg_("MCRDELT", iercod, &ibid, &xbid, " ", 7L, 1L);
2613 maostrd_();
2614 goto L9900;
2615
2616/* ALLOCATION INEXISTANTE */
2617L9003:
2618 *iercod = 3;
2619 AdvApp2Var_SysBase::maermsg_("MCRDELT", iercod, 7L);
2620 maostrd_();
2621 goto L9900;
2622
2623L9900:
2624
2625 return 0 ;
2626
2627} /* mcrdelt_ */
2628
2629
2630/*
2631C*********************************************************************
2632C
2633C FONCTION :
2634C ----------
2635C Transfert une zone memoire dans une autre en gerant les
2636C recouvrements
2637C
2638C MOTS CLES :
2639C -----------
2640C MANIPULATION, MEMOIRE, TRANSFERT, CARACTERE
2641C
2642C ARGUMENTS D'ENTREE :
2643C ------------------
2644C nb_car : integer*4 nombre de caracteres a transferer.
2645C source : zone memoire source.
2646C
2647C ARGUMENTS DE SORTIE :
2648C -------------------
2649C dest : zone memeoire destination.
2650C
2651C COMMONS UTILISES :
2652C ----------------
2653C
2654C REFERENCES APPELEES :
2655C -------------------
2656C
2657C DEMSCRIPTION/REMARQUES/LIMITATIONS :
2658C -----------------------------------
2659C Routine portable UNIX (SGI, ULTRIX, BULL)
2660C
2661C$ HISTORIQUE DES MODIFICATIONS :
2662C ----------------------------
2663C 24/01/92 : DGZ ; Recuperation de la version BULL
2664C>
2665C**********************************************************************
2666*/
2667
2668//=======================================================================
2669//function : AdvApp2Var_SysBase::mcrfill_
2670//purpose :
2671//=======================================================================
2672int AdvApp2Var_SysBase::mcrfill_(integer *size,
2673 char *tin,
2674 char *tout)
2675
2676{
2677
2678 if (mcrfill_ABS(tout-tin) >= *size)
2679 memcpy( tout, tin, *size);
2680 else if (tin > tout)
2681 {
2682 register integer n = *size;
2683 register char *jmin=tin;
2684 register char *jmout=tout;
2685 while (n-- > 0) *jmout++ = *jmin++;
2686 }
2687 else
2688 {
2689 register integer n = *size;
2690 register char *jmin=tin+n;
2691 register char *jmout=tout+n;
2692 while (n-- > 0) *--jmout = *--jmin;
2693 }
2694 return 0;
2695}
2696
2697
2698/*........................................................................*/
2699/* */
2700/* FONCTION : */
2701/* ---------- */
2702/* Routines de gestion de la memoire dynamique. */
2703/* */
2704/* Routine mcrfree */
2705/* -------------- */
2706/* */
2707/* Desallocation d'une zone memoire. */
2708/* */
2709/* CALL MCRFREE (IBYTE,IADR,IER) */
2710/* */
2711/* IBYTE INTEGER*4 : Nombre d'Octetes a Liberer */
2712/* */
2713/* IADR POINTEUR : Adresse de Depart */
2714/* */
2715/* IER INTEGER*4 : Code de Retour */
2716/* */
2717/* */
2718/* MOTS CLES : */
2719/* ----------- */
2720/* */
2721/* ARGUMENTS D'ENTREE : */
2722/* -------------------- */
2723/* */
2724/* ARGUMENTS DE SORTIE : */
2725/* --------------------- */
2726/* */
2727/* COMMONS UTILISES : */
2728/* ------------------ */
2729/* */
2730/* REFERENCES APPELEES : */
2731/* --------------------- */
2732/* */
2733/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
2734/* ----------------------------------- */
2735/* */
2736/* ** SPECIFIQUE SPS9 ** */
2737/* */
2738/* */
2739/* HISTORIQUE DES MODIFICATIONS : */
2740/* ------------------------------ */
2741/* */
2742/* 07-03-86 : FS; INSERTION DE L'ENTETE STANDARD C */
2743/* 16-09-86 : FS; MODIFICATIONS PASSAGE NIVEAU INFERIEUR */
2744/* SGI_H 05-04-90 : ACT ; ECLATEMENT DU PACKAGE CRALOC */
2745/* */
2746/*........................................................................*/
2747/* */
2748
2749//=======================================================================
2750//function : mcrfree_
2751//purpose :
2752//=======================================================================
2753int mcrfree_(integer *,//ibyte,
2754 uinteger *iadr,
2755 integer *ier)
2756
2757{
2758 *ier=0;
2759 free((void*)*iadr);
2760 if ( !*iadr ) *ier = 1;
2761 return 0;
2762}
2763
2764/*........................................................................*/
2765/* */
2766/* FONCTION : */
2767/* ---------- */
2768/* Routines de gestion de la memoire dynamique. */
2769/* */
2770/* Routine mcrgetv */
2771/* -------------- */
2772/* */
2773/* Demande d'allocation de memoire. */
2774/* */
2775/* CALL MCRGETV(IBYTE,IADR,IER) */
2776/* */
2777/* IBYTE (INTEGER*4) Nombre de Bytes d'allocation */
2778/* demandee */
2779/* */
2780/* IADR (INTEGER*4) : Resultat. */
2781/* */
2782/* IER (INTEGER*4) : Code d'erreur : */
2783/* */
2784/* = 0 ==> OK */
2785/* = 1 ==> Allocation impossible */
2786/* = -1 ==> Ofset > 2**31 - 1 */
2787/* */
2788/* MOTS CLES : */
2789/* ----------- */
2790/* */
2791/* ARGUMENTS D'ENTREE : */
2792/* -------------------- */
2793/* */
2794/* ARGUMENTS DE SORTIE : */
2795/* --------------------- */
2796/* */
2797/* COMMONS UTILISES : */
2798/* ------------------ */
2799/* */
2800/* REFERENCES APPELEES : */
2801/* --------------------- */
2802/* */
2803/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
2804/* ----------------------------------- */
2805/* */
2806/* ** SPECIFIQUE SPS9 ** */
2807/* */
2808/* */
2809/* HISTORIQUE DES MODIFICATIONS : */
2810/* ------------------------------ */
2811/* */
2812/* 07-03-86 : FS; INSERTION DE L'ENTETE STANDARD C */
2813/* 16-09-86 : FS; MODIFICATIONS PASSAGE NIVEAU INFERIEUR */
2814/*SGI_H 05-04-90 : ACT ; ECLATEMENT DU PACKAGE CRALOC */
2815/* */
2816/*........................................................................*/
2817
2818//=======================================================================
2819//function : mcrgetv_
2820//purpose :
2821//=======================================================================
2822int mcrgetv_(integer *sz,
2823 uinteger *iad,
2824 integer *ier)
2825
2826{
2827
2828 *ier = 0;
2829 *iad = (uinteger)malloc(*sz);
2830 if ( !*iad ) *ier = 1;
2831 return 0;
2832}
2833
2834
2835//=======================================================================
2836//function : mcrlist_
2837//purpose :
2838//=======================================================================
2839int mcrlist_(integer *ier)
2840
2841{
2842 /* System generated locals */
2843 integer i__1;
2844
2845 /* Builtin functions */
2846
2847 /* Local variables */
2848 static char cfmt[1];
2849 static doublereal dfmt;
2850 static integer ifmt, i__, nufmt, ntotal;
2851 static char subrou[7];
2852
2853
2854/************************************************************************
2855*******/
2856
2857/* FONCTION : */
2858/* ---------- */
2859/* IMPRESSION DU TABLEAU DES ALLOCATIONS DYNAMIQUES EN COURS */
2860
2861/* MOTS CLES : */
2862/* ----------- */
2863/* SYSTEME, ALLOCATION, MEMOIRE, LISTE */
2864
2865/* ARGUMENTS D'ENTREE : */
2866/* ------------------ */
2867/* . NEANT */
2868
2869/* ARGUMENTS DE SORTIE : */
2870/* ------------------- */
2871/* * : */
2872/* * : */
2873/* IERCOD : CODE D'ERREUR */
2874
2875/* IERCOD = 0 : OK */
2876/* IERCOD > 0 : ERREUR GRAVE */
2877/* IERCOD < 0 : WARNING */
2878/* IERCOD = 1 : DESCRIPTION DE L'ERREUR */
2879/* IERCOD = 2 : DESCRIPTION DE L'ERREUR */
2880
2881/* COMMONS UTILISES : */
2882/* ---------------- */
2883
2884/* MCRGENE VFORMT */
2885
2886/* REFERENCES APPELEES : */
2887/* ---------------------- */
2888
2889/* Type Name */
2890/* VFORMA */
2891
2892/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2893/* ----------------------------------- */
2894/* . NEANT */
2895
2896/* $ HISTORIQUE DES MODIFICATIONS : */
2897/* -------------------------------- */
2898/* 04-08-92 : HCE ; CORRECTION CTLCODE */
2899/* 10-06-92 : FCR ; CORRECTION CTLCODE */
2900/* 16-09-1991: FCR ; Suppression INCLUDE VFORMT */
2901/* 22-12-89 : DGZ ; CORRECTION DE L'EN-TETE */
2902/* PP 26.2.88 MIS VFORMA A LA PLACE DE MCRLIST */
2903/* 04-11-85 : BF ; VERSION D'ORIGINE */
2904
2905/* > */
2906/* ***********************************************************************
2907 */
2908
2909/* INCLUDE MCRGENE */
2910/* ***********************************************************************
2911 */
2912
2913/* FONCTION : */
2914/* ---------- */
2915/* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */
2916
2917/* MOTS CLES : */
2918/* ----------- */
2919/* SYSTEME, MEMOIRE, ALLOCATION */
2920
2921/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
2922/* ----------------------------------- */
2923
2924/* $ HISTORIQUE DES MODIFICATIONS : */
2925/* ------------------------------ */
2926/* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */
2927/* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
2928/* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */
2929/* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */
2930/* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */
2931/* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */
2932/* + AJOUT DE COMMENTAIRES */
2933/* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */
2934/* 15-04-85 : BF ; VERSION D'ORIGINE */
2935/* > */
2936/* ***********************************************************************
2937 */
2938
2939/* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */
2940/* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */
2941/* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */
2942/* 2 : UNITE D'ALLOCATION */
2943/* 3 : NB D'UNITES ALLOUEES */
2944/* 4 : ADRESSE DE REFERENCE DU TABLEAU */
2945/* 5 : IOFSET */
2946/* 6 : NUMERO ALLOCATION STATIQUE */
2947/* 7 : Taille demandee en allocation */
2948/* 8 : adresse du debut de l'allocation */
2949/* 9 : Taille de la ZONE UTILISATEUR */
2950/* 10 : ADRESSE DU FLAG DE DEBUT */
2951/* 11 : ADRESSE DU FLAG DE FIN */
2952/* 12 : Rang de creation de l'allocation */
2953
2954/* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */
2955/* NCORE : NBRE D'ALLOCS EN COURS */
2956/* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST
2957*/
2958/* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */
2959
2960
2961
2962/* ----------------------------------------------------------------------*
2963 */
2964
2965
2966/* ----------------------------------------------------------------------*
2967 */
2968
2969 *ier = 0;
2970 //__s__copy(subrou, "MCRLIST", 7L, 7L);
2971
2972/* ECRITURE DE L'EN TETE */
2973
2974 nufmt = 1;
2975 ifmt = mcrgene_.ncore;
2976 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2977
2978 ntotal = 0;
2979
2980 i__1 = mcrgene_.ncore;
2981 for (i__ = 1; i__ <= i__1; ++i__) {
2982 nufmt = 2;
2983 ifmt = mcrgene_.icore[i__ * 12 - 11] * mcrgene_.icore[i__ * 12 - 10]
2984 ;
2985 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2986 ntotal += ifmt;
2987/* L1001: */
2988 }
2989
2990 nufmt = 3;
2991 ifmt = ntotal;
2992 macrmsg_(subrou, &nufmt, &ifmt, &dfmt, cfmt, 7L, 1L);
2993
2994 return 0 ;
2995} /* mcrlist_ */
2996
2997
2998//=======================================================================
2999//function : mcrlocv_
3000//purpose :
3001//=======================================================================
3002int mcrlocv_(long int t,
3003 long int *l)
3004
3005{
3006 *l = t;
3007 return 0 ;
3008}
3009
3010//=======================================================================
3011//function : AdvApp2Var_SysBase::mcrrqst_
3012//purpose :
3013//=======================================================================
3014int AdvApp2Var_SysBase::mcrrqst_(integer *iunit,
3015 integer *isize,
3016 doublereal *t,
3017 long int *iofset,
3018 integer *iercod)
3019
3020{
3021
3022 integer i__1, i__2;
3023
3024 /* Local variables */
3025 static doublereal dfmt;
3026 static integer ifmt, iver;
3027 static char subr[7];
3028 static integer ksys , ibyte, irest, isyst, ier;
3029 static long int iadfd, iadff, iaddr,lofset, loc;
3030 static integer izu;
3031
3032
3033/* **********************************************************************
3034*/
3035
3036/* FONCTION : */
3037/* ---------- */
3038/* REALISATION D'UNE ALLOCATION DYNAMIQUE DE MEMOIRE */
3039
3040/* MOTS CLES : */
3041/* ----------- */
3042/* SYSTEME, ALLOCATION, MEMOIRE, REALISATION */
3043
3044/* ARGUMENTS D'ENTREE : */
3045/* ------------------ */
3046/* IUNIT : NOMBRE D'OCTEST DE L'UNITE D'ALLOCATION */
3047/* ISIZE : NOMBRE D'UNITES DEMANDEES */
3048/* T : ADRESSE DE REFERENCE */
3049
3050/* ARGUMENTS DE SORTIE : */
3051/* ------------------- */
3052/* IOFSET : DECALAGE */
3053/* IERCOD : CODE D'ERREUR, */
3054/* = 0 : OK */
3055/* = 1 : NBRE MAXI D'ALLOCS ATTEINT */
3056/* = 2 : ARGUMENTS INCORRECTS */
3057/* = 3 : REFUS D'ALLOCATION DYNAMIQUE */
3058
3059/* COMMONS UTILISES : */
3060/* ---------------- */
3061/* MCRGENE, MCRSTAC */
3062
3063/* REFERENCES APPELEES : */
3064/* ----------------------- */
3065/* MACRCHK, MACRGFL, MACRMSG, MCRLOCV,MCRCOMM, MCRGETV */
3066
3067/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3068/* ----------------------------------- */
3069
3070/* 1) UTILISATEUR */
3071/* -------------- */
3072
3073/* T EST L'ADRESSE D'UN TABLEAU BANAL,IOFSET REPRESENTE LE DEPLACEMENT EN
3074*/
3075/* UNITES DE IUNIT OCTETS ENTRE LA ZONE ALLOUEE ET LE TABLEAU T */
3076/* IERCOD=0 SIGNALE QUE L'ALLOCATION S'EST BIEN DEROULEE ,TOUTE AUTRE */
3077/* VALEUR INDIQUE UNE ANOMALIE. */
3078
3079/* EXEMPLE : */
3080/* SOIT LA DECLARATION REAL*4 T(1), DONC IUNIT=4 . */
3081/* L'APPEL A MCRRQST FAIT UNE ALLOCATION DYNAMIQUE */
3082/* ET DONNE UNE VALEUR A LA VARIABLE IOFSET, */
3083/* SI L'ON VEUT ECRIRE 1. DANS LA CINQUIEME ZONE REAL*4 */
3084/* AINSI ALLOUEE ,FAIRE: */
3085/* T(5+IOFSET)=1. */
3086
3087/* CAS D'ERREURS : */
3088/* --------------- */
3089
3090/* IERCOD=1 : NOMBRE MAXI D'ALLOCATION ATTEINT (ACTUELLEMENT 200) */
3091/* ET LE MESSAGE SUIVANT APPARAIT SUR LA CONSOLE ALPHA : */
3092/* "Le nombre maxi d'allocation de memoire est atteint : ,N" */
3093
3094/* IERCOD=2 : ARGUMENT IUNIT INCORRECT CAR DIFFERENT DE 1,2,4 OU 8 */
3095/* ET LE MESSAGE SUIVANT APPARAIT SUR LA CONSOLE ALPHA : */
3096/* "Unite d'allocation invalide : ,IUNIT" */
3097
3098/* IERCOD=3 : REFUS D'ALLOCATION DYNAMIQUE (PLUS DE PLACE MEMOIRE) */
3099/* ET LE MESSAGE SUIVANT APPARAIT SUR LA CONSOLE ALPHA : */
3100/* "Le systeme refuse une allocation dynamique de memoire de N octets"
3101*/
3102/* AVEC UN AFFICHAGE COMPLET DE TOUTES LES ALLOCATIONS EFFECTUEES */
3103/* JUSQU'A PRESENT. */
3104
3105
3106/* 2) CONCEPTEUR */
3107/* -------------- */
3108
3109/* MCRRQST FAIT UNE ALLOCATION DYNAMIQUE DE MEMOIRE VIRTUELLE SUR LA BASE
3110*/
3111/* D'ENTITES DE 8 OCTETS (QUADWORDS) ,BIEN QUE L'ALLOCATION SOIT DEMANDEE
3112*/
3113/* PAR UNITES DE IUNIT OCTETS (1,2,4,8). */
3114
3115/* LA QUANTITE DEMANDEE EST IUNIT*ISIZE OCTETS,CETTE VALEUR EST ARRONDIE
3116*/
3117/* POUR QUE L'ALLOCATION SOIT UN NOMBRE ENTIER DE QUADWORDS. */
3118
3119
3120/* $ HISTORIQUE DES MODIFICATIONS : */
3121/* -------------------------------- */
3122/* 14-04-94 : JMB; Suppression message ALLOC < 16 octets */
3123/* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
3124/* 23-09-91 : DGZ; REND LA ROUTINE PORTABLE */
3125/* 22-08-90 : DGZ; CORRECTION DE L'EN-TETE */
3126/* 21-08-90 : DGZ; AFFICHAGE DU TRACE_BACK EN PHASE DE PRODUCTION */
3127/* 22-12-89 : DGZ; CORRECTION DE L'EN-TETE */
3128/* 19-05-89 : DGZ; AJOUT DOUBLE MOT SI DECALAGE ET SUPP APPEL ACRVRF
3129*/
3130/* 17-05-89 : DGZ; CALCUL DE IOFSET DANS LE CAS OU IL EST NEGATIF */
3131/* 11-05-89 : DGZ; CONTROLE DES ECRASEMENTS DE ZONE MEMOIRE */
3132/* 04-05-88 : PP ; CHANGE MOVFLW EN MAOVERF */
3133/* 23-03-88 : PP ; CORR DE PASSAGES D'ARGUMENTS DANS MACRMSG ET MOVFLW
3134 */
3135/* 26.2.88 PP VIRE VFORMA, ET MIS MACRMSG */
3136/* 22.2.88 : PP : CHANGE I*4 EN I ET R*8 EN D P, AJOUT DE ISYST */
3137/* ,ET VIRE LE TEST SUR IBB, A REMETTRE AVANT LIVRAISON
3138*/
3139/* 09-10-1987 : Initialisation a OVERFLOW si IBB <> 0 JJM */
3140/* 10-04-87 : BF ; ALLOCATIONS CADREES SUR DOUBLES MOTS */
3141/* 07-11-85 : BF ; VERSION D'ORIGINE */
3142
3143/* > */
3144/* ***********************************************************************
3145 */
3146
3147/* COMMON DES PARAMETRES */
3148/* COMMON DES INFORMATIONS SUR LES STATISTIQUES */
3149/* INCLUDE MCRGENE */
3150
3151/* ***********************************************************************
3152 */
3153
3154/* FONCTION : */
3155/* ---------- */
3156/* TABLE DE GESTION DES ALLOCATIONS DYNAMIQUES DE MEMOIRE */
3157
3158/* MOTS CLES : */
3159/* ----------- */
3160/* SYSTEME, MEMOIRE, ALLOCATION */
3161
3162/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
3163/* ----------------------------------- */
3164
3165/* $ HISTORIQUE DES MODIFICATIONS : */
3166/* ------------------------------ */
3167/* 23-11-93 : FCR; AF93125U3A007 : MAXCR 200 --> 1000 */
3168/* 08-10-92 : FCR; DMSFRO131 : Modif pour DEBUG-ALLOC */
3169/* 25-09-91 : DGZ; AJOUT INFOs SUPPLEMENTAIREs POUR GESTION FLAGS */
3170/* 18-01-91 : DGZ; MAXCR PASSE DE 100 A 200 SUR DEMANDE GDD */
3171/* 18-05-90 : DGZ; DECLARATION TYPE INTEGER POUR MAXCR */
3172/* 20-06-88 : PP ; MAXCR PASSE DE 50 A 100, SUR DEMANDE OG */
3173/* + AJOUT DE COMMENTAIRES */
3174/* 26-02-88 : PP ; MAXCR PASSE DE 40 A 50, SUR DEMANDE AB . */
3175/* 15-04-85 : BF ; VERSION D'ORIGINE */
3176/* > */
3177/* ***********************************************************************
3178 */
3179
3180/* ICORE : TABLE DES ALLOCS EXISTANTES, AVEC POUR CHACUNE : */
3181/* 1 : NIVEAU DE PROTECTION (0=PAS PROTEGE, AUTRE=PROTEGE) */
3182/* (PROTEGE SIGNIFIE PAS DETRUIT PAR CRRSET .) */
3183/* 2 : UNITE D'ALLOCATION */
3184/* 3 : NB D'UNITES ALLOUEES */
3185/* 4 : ADRESSE DE REFERENCE DU TABLEAU */
3186/* 5 : IOFSET */
3187/* 6 : NUMERO ALLOCATION STATIQUE */
3188/* 7 : Taille demandee en allocation */
3189/* 8 : adresse du debut de l'allocation */
3190/* 9 : Taille de la ZONE UTILISATEUR */
3191/* 10 : ADRESSE DU FLAG DE DEBUT */
3192/* 11 : ADRESSE DU FLAG DE FIN */
3193/* 12 : Rang de creation de l'allocation */
3194
3195/* NDIMCR : NBRE DE DONNEES DE CHAQUE ALLOC DANS ICORE */
3196/* NCORE : NBRE D'ALLOCS EN COURS */
3197/* LPROT : COMMUNICATION ENTRE CRPROT ET MCRRQST, REMIS A 0 PAR MCRRQST
3198*/
3199/* FLAG : VALEUR DU FLAG UTILISE POUR LES DEBORDEMENTS */
3200
3201
3202
3203/* ----------------------------------------------------------------------*
3204 */
3205
3206
3207/* 20-10-86 : BF ; VERSION D'ORIGINE */
3208
3209
3210/* NRQST : NOMBRE D'ALLOCATIONS EFFECTUEES */
3211/* NDELT : NOMBRE DE LIBERATIONS EFFECTUEES */
3212/* NBYTE : NOMBRE TOTAL D'OCTETS DES ALLOCATIONS */
3213/* MBYTE : NOMBRE MAXI D'OCTETS */
3214
3215/* ----------------------------------------------------------------------*
3216 */
3217
3218 /* Parameter adjustments */
3219 --t;
3220
3221 /* Function Body */
3222 *iercod = 0;
3223
3224 if (mcrgene_.ncore >= 1000) {
3225 goto L9001;
3226 }
3227 if (*iunit != 1 && *iunit != 2 && *iunit != 4 && *iunit != 8) {
3228 goto L9002;
3229 }
3230
3231/* Calcul de la taille demandee par l'utilsateur */
3232 ibyte = *iunit * *isize;
3233
3234/* Recheche le type de version (Phase de Production ou Version Client) */
3235 madbtbk_(&iver);
3236
3237/* Controle sur la taille allouee en phase de Production */
3238
3239 if (iver == 1) {
3240
3241 if (ibyte == 0) {
3242 //s__wsle(&io___3);
3243 //do__lio(&c__9, &c__1, "Demande d'allocation nulle", 26L);
3244 AdvApp2Var_SysBase::e__wsle();
3245 maostrb_();
3246 } else if (ibyte >= 4096000) {
3247 //s__wsle(&io___4);
3248 //do__lio(&c__9, &c__1, "Demande d'allocation superieure a 4 Mega-Octets : ", 50L);
3249 //do__lio(&c__3, &c__1, (char *)&ibyte, (ftnlen)sizeof(integer));
3250 AdvApp2Var_SysBase::e__wsle();
3251 maostrb_();
3252 }
3253
3254 }
3255
3256/* ON CALCUL LA TAILLE DE LA ZONE UTILSATEUR (IZU) */
3257/* . ajout taille demandee par l'utilisateur (IBYTE) */
3258/* . ajout d'un delta pour alignement avec la base */
3259/* . on arrondit au multiple de 8 superieur */
3260
3261 mcrlocv_((long int)&t[1], (long int *)&loc);
3262 izu = ibyte + loc % *iunit;
3263 irest = izu % 8;
3264 if (irest != 0) {
3265 izu = izu + 8 - irest;
3266 }
3267
3268/* ON CALCUL LA TAILLE QUI VA ETRE DEMANDEE A LA PRIMITIVE D'ALLOC */
3269/* . ajout de la taille de la zone utilisateur */
3270/* . ajout de 8 pour un alignement de l'adresse de debut */
3271/* d'allocation sur un multiple de 8 de facon a pouvoir */
3272/* poser des flags en Double Precision sans pb d'alignement */
3273/* . ajout de 16 octets pour les deux flags */
3274
3275 ibyte = izu + 24;
3276
3277/* DEMANDE D'ALLOCATION */
3278
3279 isyst = 0;
3280/* L1001: */
3281/* IF ( ISYST.EQ.0.AND.IBYTE .LE. 100 * 1024 ) THEN */
3282/* ALLOCATION SUR TABLE */
3283/* KSYS = 1 */
3284/* KOP = 1 */
3285/* CALL MCRCOMM ( KOP , IBYTE , IADDR , IER ) */
3286/* IF ( IER .NE. 0 ) THEN */
3287/* ISYST=1 */
3288/* GOTO 1001 */
3289/* ENDIF */
3290/* ELSE */
3291/* ALLOCATION SYSTEME */
3292 ksys = 2;
3293 mcrgetv_((integer *)&ibyte, (uinteger *)&iaddr, (integer *)&ier);
3294 if (ier != 0) {
3295 goto L9003;
3296 }
3297/* ENDIF */
3298
3299/* CALCUL DES ADRESSES DES FLAGS */
3300
3301 iadfd = iaddr + 8 - iaddr % 8;
3302 iadff = iadfd + 8 + izu;
3303
3304/* CALCUL DE L'OFFSET UTILISATEUR : */
3305/* . difference entre l'adresse de depart utilisateur et */
3306/* l'adresse de la base */
3307/* . convertit cette difference dans l'unite utilisateur */
3308
3309 lofset = iadfd + 8 + loc % *iunit - loc;
3310 *iofset = lofset / *iunit;
3311
3312/* Si phase de production alors controle des flags */
3313 if (iver == 1) {
3314 macrchk_();
3315 }
3316
3317/* MISE EN PLACE DES FLAGS */
3318/* . le premier flag est mis en IADFD et le second en IADFF */
3319/* . Si phase de production alors on met a overflow la ZU */
3320 macrgfl_(&iadfd, &iadff, &iver, &izu);
3321
3322/* RANGEMENT DES PARAMETRES DANS MCRGENE */
3323
3324 ++mcrgene_.ncore;
3325 mcrgene_.icore[mcrgene_.ncore * 12 - 12] = mcrgene_.lprot;
3326 mcrgene_.icore[mcrgene_.ncore * 12 - 11] = *iunit;
3327 mcrgene_.icore[mcrgene_.ncore * 12 - 10] = *isize;
3328 mcrgene_.icore[mcrgene_.ncore * 12 - 9] = loc;
3329 mcrgene_.icore[mcrgene_.ncore * 12 - 8] = *iofset;
3330 mcrgene_.icore[mcrgene_.ncore * 12 - 7] = ksys;
3331 mcrgene_.icore[mcrgene_.ncore * 12 - 6] = ibyte;
3332 mcrgene_.icore[mcrgene_.ncore * 12 - 5] = iaddr;
3333 mcrgene_.icore[mcrgene_.ncore * 12 - 4] = mcrgene_.ncore;
3334 mcrgene_.icore[mcrgene_.ncore * 12 - 3] = iadfd;
3335 mcrgene_.icore[mcrgene_.ncore * 12 - 2] = iadff;
3336 mcrgene_.icore[mcrgene_.ncore * 12 - 1] = mcrgene_.ncore;
3337
3338 mcrgene_.lprot = 0;
3339
3340/* APPEL PERMETTANT UNE MISE EN PLACE AUTO DU SET WATCH PAR LE DEBUGGER */
3341
3342 macrstw_((integer *)&iadfd, (integer *)&iadff, (integer *)&mcrgene_.ncore);
3343
3344/* STATISTIQUES */
3345
3346 ++mcrstac_.nrqst[ksys - 1];
3347 mcrstac_.nbyte[ksys - 1] += mcrgene_.icore[mcrgene_.ncore * 12 - 11] *
3348 mcrgene_.icore[mcrgene_.ncore * 12 - 10];
3349/* Computing MAX */
3350 i__1 = mcrstac_.mbyte[ksys - 1], i__2 = mcrstac_.nbyte[ksys - 1];
3351 mcrstac_.mbyte[ksys - 1] = max(i__1,i__2);
3352
3353 goto L9900;
3354
3355/* ----------------------------------------------------------------------*
3356 */
3357/* TRAITEMENT DES ERREURS */
3358
3359/* NBRE MAXI D'ALLOC ATTEINT : */
3360L9001:
3361 *iercod = 1;
3362 ifmt = 1000;
3363 //__s__copy(subr, "MCRRQST", 7L, 7L);
3364 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3365 maostrd_();
3366 goto L9900;
3367
3368/* AURGUMENTS INCORRECTS */
3369L9002:
3370 *iercod = 2;
3371 ifmt = *iunit;
3372 //__s__copy(subr, "MCRRQST", 7L, 7L);
3373 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3374 goto L9900;
3375
3376/* LE SYSTEME REFUSE L'ALLOCATION */
3377L9003:
3378 *iercod = 3;
3379 ifmt = ibyte;
3380 //__s__copy(subr, "MCRRQST", 7L, 7L);
3381 macrmsg_(subr, iercod, &ifmt, &dfmt, " ", 7L, 1L);
3382 maostrd_();
3383 mcrlist_(&ier);
3384 goto L9900;
3385
3386/* ----------------------------------------------------------------------*
3387 */
3388
3389L9900:
3390 mcrgene_.lprot = 0;
3391 return 0 ;
3392} /* mcrrqst_ */
3393
3394//=======================================================================
3395//function : AdvApp2Var_SysBase::mgenmsg_
3396//purpose :
3397//=======================================================================
3398int AdvApp2Var_SysBase::mgenmsg_(const char *,//nomprg,
3399 ftnlen )//nomprg_len)
3400
3401{
3402 return 0;
3403} /* mgenmsg_ */
3404
3405//=======================================================================
3406//function : AdvApp2Var_SysBase::mgsomsg_
3407//purpose :
3408//=======================================================================
3409int AdvApp2Var_SysBase::mgsomsg_(const char *,//nomprg,
3410 ftnlen )//nomprg_len)
3411
3412{
3413 return 0;
3414} /* mgsomsg_ */
3415
3416
3417/*
3418C
3419C*****************************************************************************
3420C
3421C FONCTION : CALL MIRAZ(LENGTH,ITAB)
3422C ----------
3423C
3424C EFFECTUE UNE REMISE A ZERO D'UN TABLEAU DE LOGICAL OU D'INTEGER.
3425C
3426C MOTS CLES :
3427C -----------
3428C RAZ INTEGER
3429C
3430C ARGUMENTS D'ENTREE :
3431C ------------------
3432C LENGTH : NOMBRE D'OCTETS A TRANSFERER
3433C ITAB : NOM DU TABLEAU
3434C
3435C ARGUMENTS DE SORTIE :
3436C --------------------
3437C ITAB : NOM DU TABLEAU REMIS A ZERO
3438C
3439C COMMONS UTILISES :
3440C ----------------
3441C
3442C REFERENCES APPELEES :
3443C -----------------------
3444C
3445C DEMSCRIPTION/REMARQUES/LIMITATIONS :
3446C -----------------------------------
3447C
3448C Portable VAX-SGI
3449C
3450C$ HISTORIQUE DES MODIFICATIONS :
3451C --------------------------------
3452C
3453C 05-04-93 : JMB ; portabilite VAX SGI
3454C 06-01-86 : FS,GFa; CREATION (ADAPTATION VAX)
3455CSGI_H 16-02-89 : FS ; Optimisation en C en utilisant memset
3456C
3457C>
3458C***********************************************************************
3459*/
3460//=======================================================================
3461//function : AdvApp2Var_SysBase::miraz_
3462//purpose :
3463//=======================================================================
3464void AdvApp2Var_SysBase::miraz_(integer *taille,
3465 char *adt)
3466
3467{
3468 integer offset;
3469 offset = *taille;
3470 memset(adt , '\0' , *taille) ;
3471}
3472//=======================================================================
3473//function : AdvApp2Var_SysBase::mnfndeb_
3474//purpose :
3475//=======================================================================
3476integer AdvApp2Var_SysBase::mnfndeb_()
3477{
3478 integer ret_val;
3479 ret_val = 0;
3480 return ret_val;
3481} /* mnfndeb_ */
3482
3483//=======================================================================
3484//function : AdvApp2Var_SysBase::mnfnimp_
3485//purpose :
3486//=======================================================================
3487integer AdvApp2Var_SysBase::mnfnimp_()
3488{
3489 integer ret_val;
3490 ret_val = 6;
3491 return ret_val;
3492} /* mnfnimp_ */
3493
3494//=======================================================================
3495//function : AdvApp2Var_SysBase::msifill_
3496//purpose :
3497//=======================================================================
3498int AdvApp2Var_SysBase::msifill_(integer *nbintg,
3499 integer *ivecin,
3500 integer *ivecou)
3501{
3502 static integer nocte;
3503
3504/* ***********************************************************************
3505 */
3506
3507/* FONCTION : */
3508/* ---------- */
3509/* Effectue le transfert d'Integer d'une zone dans une autre */
3510
3511/* MOTS CLES : */
3512/* ----------- */
3513/* TRANSFERT , ENTIER , MEMOIRE */
3514
3515/* ARGUMENTS D'ENTREE : */
3516/* ------------------ */
3517/* NBINTG : Nombre d'entiers */
3518/* IVECIN : vecteur d'entree */
3519
3520/* ARGUMENTS DE SORTIE : */
3521/* ------------------- */
3522/* IVECOU : vecteur de sortie */
3523
3524/* COMMONS UTILISES : */
3525/* ---------------- */
3526
3527/* REFERENCES APPELEES : */
3528/* ----------------------- */
3529
3530/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3531/* ----------------------------------- */
3532
3533/* $ HISTORIQUE DES MODIFICATIONS : */
3534/* -------------------------------- */
3535/* 26-07-89 : PCR; Declaration en * pour transfert long. nulle */
3536/* (trap sinon). */
3537/* 17-10-88 : HK ; Ecriture version originale. */
3538/* > */
3539/* ***********************************************************************
3540 */
3541
3542/* ___ NOCTE : Nombre d'octets a transferer */
3543
3544 /* Parameter adjustments */
3545 --ivecou;
3546 --ivecin;
3547
3548 /* Function Body */
3549 nocte = *nbintg * sizeof(integer);
3550 AdvApp2Var_SysBase::mcrfill_((integer *)&nocte, (char *)&ivecin[1], (char *)&ivecou[1]);
3551 return 0 ;
3552} /* msifill_ */
3553
3554//=======================================================================
3555//function : AdvApp2Var_SysBase::msrfill_
3556//purpose :
3557//=======================================================================
3558int AdvApp2Var_SysBase::msrfill_(integer *nbreel,
3559 doublereal *vecent,
3560 doublereal * vecsor)
3561{
3562 static integer nocte;
3563
3564
3565/* ***********************************************************************
3566 */
3567
3568/* FONCTION : */
3569/* ---------- */
3570/* Effectue le transfert de reel d'une zone dans une autre */
3571
3572/* MOTS CLES : */
3573/* ----------- */
3574/* TRANSFERT , REEL , MEMOIRE */
3575
3576/* ARGUMENTS D'ENTREE : */
3577/* ------------------ */
3578/* NBREEL : Nombre de reels */
3579/* VECENT : vecteur d'entree */
3580
3581/* ARGUMENTS DE SORTIE : */
3582/* ------------------- */
3583/* VECSOR : vecteur de sortie */
3584
3585/* COMMONS UTILISES : */
3586/* ---------------- */
3587
3588/* REFERENCES APPELEES : */
3589/* ----------------------- */
3590
3591/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3592/* ----------------------------------- */
3593
3594/* $ HISTORIQUE DES MODIFICATIONS : */
3595/* -------------------------------- */
3596/* 26-07-89 : PCR; Declaration en * pour transfert long. nulle */
3597/* (trap sinon). */
3598/* 06-06-89 : HK ; Nettoyages. */
3599/* 17-10-88 : HK ; Ecriture version originale */
3600/* > */
3601/* ***********************************************************************
3602 */
3603
3604/* ___ NOCTE : Nombre d'octets a transferer */
3605
3606 /* Parameter adjustments */
3607 --vecsor;
3608 --vecent;
3609
3610 /* Function Body */
3611 nocte = *nbreel << 3;
3612 AdvApp2Var_SysBase::mcrfill_((integer *)&nocte, (char *)&vecent[1], (char *)&vecsor[1]);
3613 return 0 ;
3614} /* msrfill_ */
3615
3616//=======================================================================
3617//function : AdvApp2Var_SysBase::mswrdbg_
3618//purpose :
3619//=======================================================================
3620int AdvApp2Var_SysBase::mswrdbg_(const char *,//ctexte,
3621 ftnlen )//ctexte_len)
3622
3623{
3624
3625 static cilist io___1 = { 0, 0, 0, 0, 0 };
3626
3627
3628/* ***********************************************************************
3629 */
3630
3631/* FONCTION : */
3632/* ---------- */
3633/* Ecrit un message sur la console alpha si IBB>0 */
3634
3635/* MOTS CLES : */
3636/* ----------- */
3637/* MESSAGE,DEBUG */
3638
3639/* ARGUMENTS D'ENTREE : */
3640/* ------------------ */
3641/* CTEXTE : Texte a ecrire */
3642
3643/* ARGUMENTS DE SORTIE : */
3644/* ------------------- */
3645/* Neant */
3646
3647/* COMMONS UTILISES : */
3648/* ---------------- */
3649
3650/* REFERENCES APPELEES : */
3651/* ----------------------- */
3652
3653/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3654/* ----------------------------------- */
3655
3656/* $ HISTORIQUE DES MODIFICATIONS : */
3657/* -------------------------------- */
3658/* 21-11-90 : DHU; Mise au propre avant transfert a AC */
3659/* > */
3660/* ***********************************************************************
3661 */
3662/* DECLARATIONS */
3663/* ***********************************************************************
3664 */
3665
3666
3667/* ***********************************************************************
3668 */
3669/* TRAITEMENT */
3670/* ***********************************************************************
3671 */
3672
3673 if (AdvApp2Var_SysBase::mnfndeb_() >= 1) {
3674 io___1.ciunit = AdvApp2Var_SysBase::mnfnimp_();
3675 //s__wsle(&io___1);
3676 //do__lio(&c__9, &c__1, "Dbg ", 4L);
3677 //do__lio(&c__9, &c__1, ctexte, ctexte_len);
3678 AdvApp2Var_SysBase::e__wsle();
3679 }
3680 return 0 ;
3681} /* mswrdbg_ */
3682
3683
3684
3685int __i__len()
3686{
3687 return 0;
3688}
3689
3690int __s__cmp()
3691{
3692 return 0;
3693}
3694
3695//=======================================================================
3696//function : do__fio
3697//purpose :
3698//=======================================================================
3699int AdvApp2Var_SysBase::do__fio()
3700{
3701return 0;
3702}
3703//=======================================================================
3704//function : do__lio
3705//purpose :
3706//=======================================================================
3707int AdvApp2Var_SysBase::do__lio ()
3708{
3709 return 0;
3710}
3711//=======================================================================
3712//function : e__wsfe
3713//purpose :
3714//=======================================================================
3715int AdvApp2Var_SysBase::e__wsfe ()
3716{
3717 return 0;
3718}
3719//=======================================================================
3720//function : e__wsle
3721//purpose :
3722//=======================================================================
3723int AdvApp2Var_SysBase::e__wsle ()
3724{
3725 return 0;
3726}
3727//=======================================================================
3728//function : s__wsfe
3729//purpose :
3730//=======================================================================
3731int AdvApp2Var_SysBase::s__wsfe ()
3732{
3733 return 0;
3734}
3735//=======================================================================
3736//function : s__wsle
3737//purpose :
3738//=======================================================================
3739int AdvApp2Var_SysBase::s__wsle ()
3740{
3741 return 0;
3742}
3743
3744
3745/*
3746C*****************************************************************************
3747C
3748C FONCTION : CALL MVRIRAZ(NBELT,DTAB)
3749C ----------
3750C Effectue une remise a zero d'un tableau de DOUBLE PRECISION
3751C
3752C MOTS CLES :
3753C -----------
3754C MVRMIRAZ DOUBLE
3755C
3756C ARGUMENTS D'ENTREE :
3757C ------------------
3758C NBELT : Nombre d'elements du tableau
3759C DTAB : Tableau a initialiser a zero
3760C
3761C ARGUMENTS DE SORTIE :
3762C --------------------
3763C DTAB : Tableau remis a zero
3764C
3765C COMMONS UTILISES :
3766C ----------------
3767C
3768C REFERENCES APPELEES :
3769C -----------------------
3770C
3771C DEMSCRIPTION/REMARQUES/LIMITATIONS :
3772C -----------------------------------
3773C
3774C
3775C
3776C$ HISTORIQUE DES MODIFICATIONS :
3777C --------------------------------
3778C 21-11-95 : JMF ; Creation a partir de miraz
3779C
3780C>
3781C***********************************************************************
3782*/
3783//=======================================================================
3784//function : AdvApp2Var_SysBase::mvriraz_
3785//purpose :
3786//=======================================================================
3787void AdvApp2Var_SysBase::mvriraz_(integer *taille,
3788 char *adt)
3789
3790{
3791 integer offset;
3792 offset = *taille * 8 ;
3793 /* printf(" adt %d long %d\n",adt,offset); */
3794 memset(adt , '\0' , offset) ;
3795}