1 subroutine gmalog ( nomtab, adut, nbplac, type1,
2 > minmeg, ntroug, nballg, totalg,
3 > ptroug, ltroug, ptallg, lgallg, adug,
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
27 c adut est toujours une adresse utile :
28 c elle peut etre utilisee sous la forme :
32 c que contient ptall :
34 c En modgm 0 ( statique ) :
35 c decalage par rapport au debut de la zone : decal
37 c adug = (ad1-ad0)/ltype+decal
38 c entre deux tableaux : adug1 - adug2 = ptallg1 - ptallg2
40 c En modgm 1 ( semi-dynamique ) :
41 c decalage par rapport au debut de la zone : decal
43 c adug = (ad1-ad0)/ltype+decal+1
44 c entre deux tableaux : adug1 - adug2 = ptallg1 - ptallg2
46 c En modgm 2 ( dynamique ) :
47 c retour de gbalme c.a.d. adresse absolue adabs
49 c adug = (adabs-ad0)/ltype+2
50 c entre deux tableaux : adug1 - adug2 = (ptallg1 - ptallg2)/ltype
52 c cf. commentaires dans le source pour plus de details sur
53 c le calcul de adresses "utiles"
54 c (= indices dans les tableaux ...mem) en dynamique.
56 c ......................................................................
58 c . programme generique d'allocation d'un tableau
59 c . affectation du debut du premier trou memoire suffisant
60 c . mise a jour du tableau des trous
61 c . mise a jour des tableaux des variables allouees (stats)
64 c . donnees nomtab --> nom du tableau a allouer (8 caracteres au plus)
65 c . nbplac --> nombre de places demandees
66 c . type1 --> type du tableau :r,i,s
67 c .modifies minmeg <--> valeur entiere memorisant la plus petite
68 c . dimension du dernier trou afin de connaitre
69 c . le passage le plus delicat rencontre au cours
70 c . de l'allocation. cette valeur est calculee
71 c . apres compression (pour statistiques)
72 c . ntroug <--> valeur entiere . nombre de trous presents
73 c . nballg <--> nombre de tableaux deja alloues
74 c . totalg <--> valeur entiere cumulant les demandes
75 c . successives de memoire
76 c . ptroug <--> tableau entier contenant les pointeurs
77 c . repertoriant la position des trous
78 c . ltroug <--> tableau entier contenant la longueur des trous
79 c . ptallg <--> tableau entier contenant les pointeurs
80 c . repertoriant la position des tableaux
81 c . adug <--> tableau entier contenant les adresses utiles
83 c . lgallg <--> tableau entier contenant la longueur des
85 c . nommxg <--> chaine de caractere(*8) contenant le nom du
86 c . plus grand (?) tableau associe a minmeg
87 c . nomalg <--> tableau de chaines de caracteres contenant
88 c . le nom associe a chaque tableau deja alloue
89 c .resultat adut <-- pointeur associe
90 c . la valeur renvoyee est indefinie en cas de
93 c ......................................................................
96 c 0. declarations et dimensionnement
99 c 0.1. ==> generalites
105 parameter ( nompro = 'GMALOG' )
132 character*8 nommxg, nomalg(maxtab)
135 integer adut , nbplac
136 integer minmeg, ntroug, nballg, totalg
137 integer ptroug(maxtrs) , ltroug(maxtrs)
138 integer ptallg(maxtab) , lgallg(maxtab)
140 c 0.4. ==> variables locales
145 integer i, iaux, maxo, mtoto
147 integer ltype, ad0, ad1, nrotab, nrotro
148 integer nbcain, nfois, nentg
152 character*1 carint(1)
157 parameter ( nbmess = 10 )
159 character*80 texte(nblang,nbmess)
161 c 0.5. ==> initialisations
165 c ______________________________________________________________________
173 #ifdef _DEBUG_HOMARD_
174 write (ulsort,texte(langue,1)) 'Entree', nompro
178 texte(1,4) = '(/,''La gestion de la memoire est statique.'')'
179 texte(1,5) ='(/,''La gestion de la memoire est semi-dynamique.'')'
180 texte(1,6) = '(/,''La gestion de la memoire est dynamique.'')'
182 texte(2,4) = '(/,''A static memory management is used.'')'
183 texte(2,5) = '(/,''A semi-dynamic memory management is used.'')'
184 texte(2,6) = '(/,''A dynamic memory management is used.'')'
186 #ifdef _DEBUG_HOMARD_
187 write (ulsort,texte(langue,modgm+4))
196 #ifdef _DEBUG_HOMARD_
197 write (ulsort,*) 'type1 = ', type1
199 if ( type1.eq.'i' .or. type1.eq.'I' ) then
205 else if ( type1.eq.'r' .or. type1.eq.'R' ) then
211 else if ( type1.eq.'s' .or. type1.eq.'S' ) then
213 blabla = 'caractere '
218 write(ulsort,10000) type1
220 cgn call ugstop( nompro, ulsort, 1, 1, 1 )
222 #ifdef _DEBUG_HOMARD_
223 write (ulsort,*) 'ltype = ', ltype
224 write (ulsort,*) 'ad0 = ', ad0, ', ad1 = ', ad1
226 10000 format (//2x,' ****** spg GMALOG *****',
227 > /2x,'Le type ',a1,' est inconnu.',
228 > /2x,'Il faut r, i ou s',
229 > /2x,' ===> arret dans le gestionnaire de memoire')
234 #ifdef _DEBUG_HOMARD_
235 write (ulsort,*) '2. verifications ; coergm = ', coergm
238 c 2.1. ==> nature du nom
239 c aucun caractere n'est interdit, mais on met un blanc
240 c dans le tableau pour ne plus avoir de messages ftnchek
242 if ( coergm.eq.0 ) then
246 call gmntve ( nomtab, nomvar, nbcain, carint, coergm )
248 if ( coergm.ne.0 ) then
249 write(ulsort,21100) nompra
251 cgn call ugstop( nompro, ulsort, 1, 1, 1 )
254 21100 format ( 2x,'Probleme a l''appel au spg GMALOG via ',a6,
255 > /,4x,' ===> arret dans le gestionnaire de memoire')
259 c 2.2. ==> verification du nombre de tableaux deja alloues
260 c . pour un tableau "ordinaire", on s'arrete un peu avant
261 c le maximum pour se garder une marge dans les impressions
262 c d'arret du programme
263 c . si c'est un tableau de nom temporaire, on controle
264 c sur le vrai nombre maximum de tableaux car il se peut
265 c que ce soit dans les impressions de deboggage, donc il ne
266 c faudrait pas boucler en controlant trop juste.
268 if ( coergm.eq.0 ) then
270 if ( nomvar(1:1).eq.caint1 ) then
276 if ( nballg.gt.maxtab-iaux .and. nfois.eq.0 ) then
278 if ( type1.eq.'r' .or. type1.eq.'R' ) then
280 else if ( type1.eq.'i' .or. type1.eq.'I' ) then
282 else if ( type1.eq.'s' .or. type1.eq.'S' ) then
285 write(ulsort,21100) nompra
286 write(ulsort,22000) nomvar, nballg, maxtab
288 cgn call ugstop( nompro, ulsort, 1, 1, 1 )
295 if ( coergm.eq.0 ) then
297 if ( nballg.eq.maxtab-iaux .and. nfois.eq.0 ) then
299 if ( type1.eq.'r' .or. type1.eq.'R' ) then
301 else if ( type1.eq.'i' .or. type1.eq.'I' ) then
303 else if ( type1.eq.'s' .or. type1.eq.'S' ) then
306 write(ulsort,21100) nompra
307 write(ulsort,22000) nomvar, maxtab-iaux, maxtab
309 cgn call ugstop( nompro, ulsort, 1, 1, 1 )
314 22000 format ( 2x,'GMALOG : Allocation de ',a8,
315 > /,4x,'C''est le tableau numero ',i8 ,
316 > /,4x,'Le nombre maxi de tableaux allouables vaut ',i8 ,
317 > /,4x,'Il faut changer maxtab dans le gestionnaire',
318 > 1x,'(fichier a inclure gmmaxt.h)',
319 > /,4x,' ===> arret du au gestionnaire memoire gm')
321 c 2.3. ==> impossible d'avoir un nombre de places < 0
323 if ( coergm.eq.0 ) then
325 if (nbplac.lt.0) then
326 write(ulsort,21100) nompra
327 write(ulsort,23000) nompra, nomvar, nbplac
329 cgn call ugstop( nompro, ulsort, 1, 1, 1 )
334 23000 format ( 2x,'Mauvais appel au spg GMALOG via ',a6,
335 > /,4x,' pour le tableau ',a8,
336 > /,4x,'Nombre de valeurs requises negatif ( ',i15,')' ,
337 > /,4x,' ===> arret dans le gestionnaire de memoire')
339 c 2.4. ==> verif que le nom n'est pas deja utilise
341 if ( coergm.eq.0 ) then
344 if ( nomalg(i).eq.nomvar ) then
345 write(ulsort,24000) nompra, nomvar
348 cgn call ugstop( nompro, ulsort, 1, 1, 1 )
356 24000 format ( 2x,'Probleme a l''appel au spg GMALOG via ',a6,
357 > /,4x,'Nom du tableau (',a8,') deja utilise' ,
358 > /,4x,' ===> arret dans le gestionnaire de memoire')
363 #ifdef _DEBUG_HOMARD_
364 write (ulsort,*) '3. allocations ; coergm = ', coergm
367 c 3.1. ==> en mode statique ou semi-dynamique
369 if ( modgm.le.1 ) then
370 #ifdef _DEBUG_HOMARD_
371 cgn if ( nomtab.eq.'MaEn002f' ) then
372 write (ulsort,*) 'nomtab = ', nomtab
373 write (ulsort,*) '3.1. Mode stat ou semi/dyna ; coergm = ', coergm
374 write (ulsort,*) 'nbplac = ', nbplac
378 c 3.1.1. ==> si on a demande d'allouer un tableau de longueur nulle,
379 c on le place en premiere position.
380 c l'inconvenient est que cela oblige a remanier la liste
381 c complete des tableaux a la fin de ce programme
382 c mais le gros avantage est qu'en cas de desallocation
383 c on ne risque pas de trouver un tableau de longueur
384 c nulle encadre par deux trous ; les trous sont ainsi
385 c toujours regroupes de maniere compacte
387 if ( nbplac.eq.0 ) then
389 if ( coergm.eq.0 ) then
398 c 3.1.2. ==> allocation d'un tableau de longueur non nulle
400 c 3.1.2.1. recherche du premier trou suffisamment grand
401 c si aucun trou n'est disponible, impression d'un message,
402 c puis arret de l'execution
404 if ( coergm.eq.0 ) then
406 do 311 iaux = 1 , ntroug
407 if ( ltroug(iaux).ge.nbplac ) then
413 call gmmaxi ( maxo , mtoto , ntroug , ltroug )
415 write(ulsort, 30100 ) nbplac, blabla, nomvar
416 write(ulsort, 30200 ) maxo, ntroug, mtoto
418 if ( type1.eq.'r' .or. type1.eq.'R' ) then
420 else if ( type1.eq.'i' .or. type1.eq.'I' ) then
422 else if ( type1.eq.'s' .or. type1.eq.'S' ) then
427 cgn call ugstop( nompro, ulsort, 1, 2, 1 )
431 c 3.1.2.2. ==> une place ayant ete trouvee, on met le tableau au debut
433 c on memorise si c'etait le dernier trou ou non
437 if ( coergm.eq.0 ) then
439 pointe = ptroug(nrotro)
441 if ( nrotro.eq.ntroug ) then
449 c 3.1.2.3. ==> gestion des trous
450 c . si le trou a la meme taille que le tableau a allouer,
451 c il doit disparaitre. il faut alors decaler d'un cran
452 c les eventuels trous qui suivent.
453 c . si le trou est plus grand que le tableau a allouer,
454 c il est simplement decale et raccourci.
456 if ( coergm.eq.0 ) then
458 if ( ltroug(nrotro).eq.nbplac ) then
461 do 313 iaux = nrotro , ntroug
462 ptroug(iaux) = ptroug(iaux+1)
463 ltroug(iaux) = ltroug(iaux+1)
465 ptroug(ntroug+1) = iindef
466 ltroug(ntroug+1) = iindef
469 if ( minmeg.gt.0 ) then
477 ptroug(nrotro) = ptroug(nrotro) + nbplac
478 ltroug(nrotro) = ltroug(nrotro) - nbplac
484 c 3.1.2.4. ==> on met a jour la longueur minimale du dernier trou.
486 if ( coergm.eq.0 ) then
488 if ( ntroug.le.0 ) then
490 else if ( minmeg.gt.ltroug(ntroug) ) then
492 minmeg = ltroug(ntroug)
497 c 3.1.2.5. ==> . si le tableau est place au debut du dernier trou,
498 c il vient a la suite du dernier tableau enregistre.
499 c . si le tableau est place dans un trou qui est au milieu
500 c des tableaux, il faut l'inserer entre des tableaux
501 c deja alloues. on recherche le premier tableau dont
502 c l'adresse est plus grande que l'adresse du-dit trou.
504 if ( coergm.eq.0 ) then
513 if (ptallg(i).gt.pointe) then
519 c NB: si on passe ici, c'est bizarre
520 c (mauvaise gestion des trous?)
532 c 3.1.3. ==> calcul de l'adresse utile
534 if ( coergm.eq.0 ) then
536 adut = ((ad1-ad0)/ltype) + pointe
537 if ( modgm.eq.1 ) then
543 c 3.1.4. ==> mise a jour des listes par decalage des informations
544 c relatives aux tableaux qui viennent apres le tableau
545 c en cours d'allocation
547 if ( coergm.eq.0 ) then
549 do 316 iaux = nballg , nrotab , -1
550 nomalg(iaux+1) = nomalg(iaux)
551 ptallg(iaux+1) = ptallg(iaux)
552 lgallg(iaux+1) = lgallg(iaux)
553 adug(iaux+1) = adug(iaux)
558 c 3.2. ==> cas du mode dynamique
559 c le tableau alloue est toujours le dernier
562 #ifdef _DEBUG_HOMARD_
563 write (ulsort,*) '3.2. Mode dynamique ; coergm = ', coergm
566 if ( coergm.eq.0 ) then
568 #ifdef _DEBUG_HOMARD_
569 write (ulsort,*) 'appel de gbalme par gmalog, avec :'
570 write (ulsort,*) '... type1 : ', type1
571 write (ulsort,*) '... nbplac+1 : ', nbplac+1
573 call gbalme ( type1, nbplac+1, pointe )
577 if ( coergm.ne.0 ) then
579 write(ulsort,30100) nbplac+1, blabla, nomvar
580 cgn call ugstop( nompro, ulsort, 1, 2, 1 )
586 #ifdef _DEBUG_HOMARD_
587 write (ulsort,*) 'pointe = ', pointe
588 write (ulsort,*) 'pointe-ad0 = ', pointe-ad0
590 adut = (pointe-ad0)/ltype
592 c En particulier pour les "gros types"
593 c on n'a pas vraiment de garantie que la division precedente
594 c "tombe juste". Le fait d'avoir en fait alloue nbplac+1 au lieu de
595 c nbplac (cf. appel a gbalme ci-dessus) permet de se mettre a l'abri
596 c de ce genre de probleme (en plus d'eviter de demander au systeme
597 c un malloc avec taille nulle, ce qui ne se passe pas toujours bien).
599 c Cette maniere d'evaluer l'adresse utile adut permet aussi de se
600 c premunir du cas ( extremement rare apparemment ) ou pointe-ad0
601 c serait negatif (habituellement, les communs -donc ad0- sont charges
602 c en memoire a des adresses inferieures au "heap" -donc pointe-).
604 if ( adut*ltype .ge. pointe-ad0 ) then
610 c gestion des grandeurs permettant d'obtenir des statistiques globales
611 c (meme en mode dynamique) :
613 if ( minmeg.ge.nbplac ) then
614 minmeg = minmeg - nbplac
615 if ( minmeg.eq.0 .and. nbplac.gt.0 ) then
619 if ( type1.eq.'r' .or. type1.eq.'R' ) then
620 rmem(1) = rmem(1) + dble(nbplac - max( 0, minmeg ))
621 else if ( type1.eq.'i' .or. type1.eq.'I' ) then
622 imem(1) = imem(1) + nbplac - max( 0, minmeg )
623 else if ( type1.eq.'s' .or. type1.eq.'S' ) then
624 if (index(smem(1),'*').le.0) then
625 read(smem(1),'(i8)') nentg
626 nentg = nentg + nbplac - max( 0, minmeg )
627 write(smem(1),'(i8)') nentg
630 if ( nbplac.gt.0 .or. minmeg.lt.0 ) then
640 c 3.3. ==> memorisation des caracteristiques du nouveau tableau
641 c et statistiques globales
642 #ifdef _DEBUG_HOMARD_
643 write (ulsort,*) '3.3. Memorisation ; coergm = ', coergm
646 if ( coergm.eq.0 ) then
650 nomalg(nrotab) = nomvar
651 ptallg(nrotab) = pointe
652 lgallg(nrotab) = nbplac
655 totalg = totalg + nbplac
661 #ifdef _DEBUG_HOMARD_
662 write (ulsort,*) '3.5. messages ; coergm = ', coergm
666 >/,'Impossible d''allouer',i15,' places en ',a16,
667 > ' pour ''',a8,'''',
670 >/,10x,'Le maximum disponible est de',i15,' places ;',
671 >/,10x,'Il y a',i5,' trous totalisant',i15,' places.'/)
677 if ( coergm.ne.0 ) then
683 #ifdef _DEBUG_HOMARD_
684 write (ulsort,texte(langue,1)) 'Sortie', nompro