1 subroutine gmdesg ( nomtab, nbplac, type1, detlg0,
2 > ntroug, nballg, ptroug, ltroug,
3 > ptallg, lgallg, adug, nomalg )
4 c ______________________________________________________________________
8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
11 c aupres des huissiers de justice Simart et Lavoir a Clamart
12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
13 c aupres des huissiers de justice
14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
16 c HOMARD est une marque deposee d'Electricite de France
22 c ______________________________________________________________________
23 c ......................................................................
24 c . creation octobre 93 gn
25 c ......................................................................
27 c le programme libere nbplac mots de memoire a partir de la fin
28 c pour le tableau nomtab ==================
30 c ......................................................................
33 c . programme generique de desallocation d'un emplacement memoire
34 c . 'attention' le contenu du tableau est inchange
37 c . recherche du premier trou memoire suivant
38 c . mise a jour du tableau des trous (rallonge ou creation)
39 c . mise a jour des tableaux des variables allouees (stats)
42 c . donnees nomtab --> nom du tableau concerne
43 c . nbplac --> nombre de mots liberes a partir de la fin
44 c . type1 --> type du tableau :r,i,s,d, ou c
45 c . detlg0 --> vrai/faux pour la destruction du tableau s'il
46 c . devient de longueur nulle
47 c .modifies ntroug <--> valeur entiere . nombre de trous presents
48 c . nballg <--> nombre de tableaux deja alloues
49 c . ptroug <--> tableau entier contenant les pointeurs
50 c . repertoriant la position des trous
51 c . ltroug <--> tableau entier contenant la longueur des trous
52 c . ptallg <--> tableau entier contenant les pointeurs
53 c . repertoriant la position des tableaux
54 c . adug <--> adresses utiles des tableaux
55 c . telles que retournees par gbcara
56 c . lgallg <--> tableau entier contenant la longueur des
58 c . nomalg <--> tableau de chaines de caracteres contenant
59 c . le nom associe a chaque tableau deja alloue
60 c . - restriction d' usage
61 c . le spg n'accepte de desallouer la zone prescrite que si celle
62 c . ci est integralement contenue dans un tableau effectivement
63 c . alloue precedemment. cela autorise une desallocation partielle.
64 c . il ne desalloue jamais un tableau de longueur nulle. en effet
65 c . meme si pointe coincide avec l'adresse d'un tableau de longueur
66 c . nulle il n'est pas possible de savoir si l'on a voulu
67 c . desallouer la fin du tableau precedent mais il se trouve que
68 c . nbplac est nul ou le tableau de longueur nulle qui se trouve a
71 c ......................................................................
74 c 0. declarations et dimensionnement
77 c 0.1. ==> generalites
83 parameter ( nompro = 'GMDESG' )
108 character*8 nomtab, nomalg(maxtab)
110 integer nbplac, ntroug, nballg
111 integer ptroug(maxtrs) , ltroug(maxtrs)
112 integer ptallg(maxtab) , lgallg(maxtab)
117 c 0.4. ==> variables locales
122 c decal : decalage / au debut de la zone
123 c uniquement en mode statique ou semi-dynamique
127 c adabs : adressr absolue
133 integer iaux, jaux, nrotab, nrotro
137 logical jointb, jointh
139 c 0.5. ==> initialisations
140 c ______________________________________________________________________
143 parameter ( nbmess = 10 )
144 character*80 texte(nblang,nbmess)
152 #ifdef _DEBUG_HOMARD_
153 write (ulsort,texte(langue,1)) 'Entree', nompro
163 if ( type1.eq.'i' .or. type1.eq.'I' ) then
167 elseif ( type1.eq.'r' .or. type1.eq.'R' ) then
171 elseif ( type1.eq.'s' .or. type1.eq.'S' ) then
176 write(ulsort,10000) type1
180 10000 format(/2x,'Le type ',a1,' est inconnu.',
181 > /2x,'Il faut r, i ou s')
187 if ( coergm.eq.0 ) then
189 if ( nbplac .lt. 0 ) then
190 write(ulsort,20001) nbplac
196 20001 format(/2x,'On demande a liberer ',i8,' places.')
199 c 3. recherche du tableau
202 if ( coergm.eq.0 ) then
204 c 3.1.1. ==> recherche du numero du tableau concerne
206 call gbcara ( nomtab , nrotab, adut , iaux , typobs )
208 c 3.1.2. ==> il ne faut pas enlever plus de places qu'il n'y en a deja
210 if ( coergm.eq.0 ) then
211 if ( nbplac.gt.lgallg(nrotab) ) then
212 write(ulsort,20001) nbplac
213 write(ulsort,30001) lgallg(nrotab)
218 30001 format(2x,'Or le tableau est alloue avec ',i8,' places.')
220 c 3.1.3. ==> si c'est bon, on repere les adresses de la zone a liberer
221 c si aucun tableau trouve --> messages d'erreur et arret
223 if ( coergm.eq.0 ) then
224 if ( modgm.le.1 ) then
225 decal = ptallg(nrotab) + lgallg(nrotab) - nbplac
227 adabs = ptallg(nrotab)
234 c 4. en mode statique ou semi-dynamique, il faut gerer les trous
235 c quand on desalloue un nombre non nul de places
238 if ( coergm.eq.0 .and. modgm.le.1 .and. nbplac.ne.0 ) then
240 c 4.1. ==> localisation de l'adresse donnee par rapport aux trous
243 do 41 iaux = 1, ntroug
244 if ( ptroug(iaux).gt.decal ) then
250 c 4.2. ==> gestion du nouveau trou
254 if ( nrotro.eq.0 ) then
256 c 4.2.1. ==> la zone liberee se situe apres tous les trous existants
257 c --> cela constitue un nouveau trou en fin de tableau
260 ptroug(ntroug) = decal
261 ltroug(ntroug) = nbplac
265 c 4.2.2. ==> on a trouve un trou qui est place apres la zone a liberer
266 c Si ce n'est pas le premier, y en a-t-il un autre avant ?
268 if ( nrotro.eq.1 ) then
271 jointb = ((ptroug(nrotro-1)+ltroug(nrotro-1)).ge.decal)
274 jointh = ( (decal+nbplac).ge.ptroug(nrotro) )
276 c ---> action suivant les 4 cas possibles
278 if (jointb.and.jointh) then
280 c fusion par le bas et le haut (elimination d'un trou)
282 ltroug(nrotro-1) = ltroug(nrotro) +
283 > ptroug(nrotro)-ptroug(nrotro-1)
285 do 43 iaux = nrotro, ntroug
286 ptroug(iaux) = ptroug(iaux+1)
287 ltroug(iaux) = ltroug(iaux+1)
289 ptroug(ntroug+1) = iindef
290 ltroug(ntroug+1) = iindef
292 else if (jointb) then
295 ltroug(nrotro-1) = decal + nbplac - ptroug(nrotro-1)
297 else if (jointh) then
300 ltroug(nrotro) = ptroug(nrotro) + ltroug(nrotro) - decal
301 ptroug(nrotro) = decal
305 c creation d'un nouveau trou au milieu
308 do 44 iaux = nrotro+1, ntroug
309 ptroug(jaux) = ptroug(jaux-1)
310 ltroug(jaux) = ltroug(jaux-1)
313 ptroug(nrotro) = decal
314 ltroug(nrotro) = nbplac
323 c 5. raccourcissement effectif
326 if ( coergm.eq.0 ) then
328 c 5.1. ==> si tout est bon, on raccourcit
330 lgallg(nrotab) = lgallg(nrotab) - nbplac
332 c 5.2. ==> si la longueur finale est nulle et que l'on ne garde
333 c pas un tableau de longueur nulle, on desalloue totalement
335 if ( detlg0 .and. lgallg(nrotab).eq.0 ) then
337 c 5.2.1. ==> on supprime le tableau des tables
341 do 52 iaux = nrotab, nballg
342 nomalg(iaux) = nomalg(iaux+1)
343 ptallg(iaux) = ptallg(iaux+1)
344 lgallg(iaux) = lgallg(iaux+1)
345 adug(iaux) = adug(iaux+1)
348 nomalg(nballg+1) = sindef
349 ptallg(nballg+1) = iindef
350 lgallg(nballg+1) = iindef
351 adug(nballg+1) = iindef
353 c 5.2.2. ==> en mode dynamique, on libere la memoire
355 if ( modgm.eq.2 ) then
357 call gblibe( type1, nbplac, adabs, coergm )
359 if ( coergm.ne.0 ) then
360 write(ulsort,*) nompro, ' modgm 2 erreur au free'
365 else if ( modgm.eq.2 .and. nbplac.gt.0 ) then
367 c Raccourcissement "partiel" en mode dynamique:
369 c (noter que ce raccourcissement partiel, ou re-allocation,
370 c n'est pas vital au fonctionnement de gm)
372 cgn write(ulsort,*) 'appel de gbralo'
373 call gbralo( type1, lgallg(nrotab)+1,
374 > ptallg(nrotab), coergm )
375 cgn write(ulsort,*) 'retour de gbralo'
377 if ( coergm.ne.0 ) then
379 write(ulsort,*) nompro, ' modgm 2 erreur au realloc'
380 ptallg(nrotab) = adabs
382 else if ( ptallg(nrotab).ne.adabs ) then
384 c cas ou l'adresse memoire du tableau a ete changee :
385 c on recalcule l'adresse "utile" adug(nrotab)
387 adabs = (ptallg(nrotab)-ad0)/ltype
389 if ( adabs*ltype .ge. ptallg(nrotab)-ad0 ) then
390 adug(nrotab) = adabs + 1
392 adug(nrotab) = adabs + 2
398 if (coergm.eq.0 .and. modgm.eq.2 .and. nbplac.gt.0) then
400 c gestion des grandeurs permettant d'obtenir des statistiques globales
401 c (meme en mode dynamique) :
403 if ( type1.eq.'r' .or. type1.eq.'R' ) then
404 minmer = minmer + nbplac
405 else if ( type1.eq.'i' .or. type1.eq.'I' ) then
406 minmei = minmei + nbplac
407 else if ( type1.eq.'s' .or. type1.eq.'S' ) then
408 minmes = minmes + nbplac
419 if ( coergm.ne.0 ) then
421 write(ulsort,50000) nompro, nompra, nomtab
423 if ( type1.eq.'r' .or. type1.eq.'R' ) then
425 elseif ( type1.eq.'i' .or. type1.eq.'I' ) then
427 elseif ( type1.eq.'s' .or. type1.eq.'S' ) then
431 call ugstop ( nompro, ulsort, 0, 1, 1 )
435 50000 format(/2x,' ****** spg ',a,' via ',a6,' *****',
436 > /2x,' probleme pour le tableau ',a8,
437 > /2x,' ===> arret a cause du gestionnaire de memoire',
438 > /2x ,'Verifier votre appel a l''aide des infos suivantes')
444 if ( coergm.ne.0 ) then