1 subroutine gasgmc ( nomemc, codret )
2 c ______________________________________________________________________
6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
9 c aupres des huissiers de justice Simart et Lavoir a Clamart
10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
11 c aupres des huissiers de justice
12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
14 c HOMARD est une marque deposee d'Electricite de France
20 c ______________________________________________________________________
22 c supprimer le graphe d'un objet en memoire centrale
23 c ______________________________________________________________________
25 c . nom . e/s . taille . description .
26 c .____________________________________________________________________.
27 c . nomemc . e .char(*) . nom etendu en memoire centrale .
28 c . codret . s . ent . code retour de l'operation .
30 c . . . . -1 : nom d'objet invalide .
31 c . . . . -2 : Probleme dans la liberation d'un objet.
33 c . . . . -3 : Probleme au detachement .
34 c . . . . -4 : L'objet n'est pas alloue. .
35 c . . . . -5 : L'objet est simple .
36 c . . . . -6 : dimensionnement insuffisant .
37 c .____________________________________________________________________.
40 c 0. declarations et dimensionnement
43 c 0.1. ==> generalites
48 parameter ( nompro = 'GASGMC' )
70 c 0.4. ==> variables locales
74 character*8 chemin(ix,jx), objter
75 character*8 objdet(nbjx), objlib(nbjx)
76 character*8 obrepc, obterc, chterc
79 integer iaux, jaux, kaux
80 integer igrp, nj1, nbojdl, nbojdd, ityc, ioal
81 integer impopt, nbchem, lgchem(ix)
83 logical alloue, attach
86 parameter ( nbmess = 20 )
87 character*80 texte(nblang,nbmess)
89 c 0.5. ==> initialisations
91 c ... juste pour ne plus avoir de messages ftnchek :
93 data objdet / nbjx * ' ' /
94 data objlib / nbjx * ' ' /
101 c ______________________________________________________________________
109 #ifdef _DEBUG_HOMARD_
110 write (ulsort,texte(langue,1)) 'Entree', nompro
114 texte(1,6) = '(1x,''Suppression du graphe de l''''objet '',a8)'
115 texte(1,4) = '(1x,''en memoire centrale.'')'
116 texte(1,11) = '(1x,''Le nom d''''objet est invalide.'')'
118 > '(1x,''Probleme a la liberation d''''un objet du chemin.'')'
119 texte(1,13) = '(1x,''Probleme lors d''''un detachement.'')'
120 texte(1,14) = '(1x,''L''''objet n''''est pas alloue.'')'
121 texte(1,15) = '(1x,''L''''objet est simple.'')'
122 texte(1,16) = '(1x,''Dimensionnement du chemin insuffisant.'')'
124 texte(2,6) = '(1x,''Suppression of the graph of the object '',a8)'
125 texte(2,4) = '(1x,''in central memory.'')'
126 texte(2,11) = '(1x,''The name of the object is not valid.'')'
127 texte(2,12) = '(1x,''Problem in freeing an object of the path.'')'
128 texte(2,13) = '(1x,''Problem in untighting.'')'
129 texte(2,14) = '(1x,''The object is not allocated.'')'
130 texte(2,15) = '(1x,''The object is simple.'')'
131 texte(2,16) = '(1x,''Unsufficient path dimension.'')'
136 c 2. on recherche le type d'allocation
139 c 2.1. ==> decodage du nom
141 call gbdnoe(nomemc,obrepc,obterc,chterc,codret)
142 cgn write(1,*) nompro, codret
144 if ( codret.lt.0 .or. codret.eq.1 .or. codret.eq.2 ) then
149 cgn write(1,*) nompro, codret, coergm
151 c 2.2. ==> l'objet "obterc" est-il alloue ?
152 c ioal = 0 : objet non alloue
153 c ioal = 1 : objet structure alloue
154 c ioal = 2 : objet simple alloue
156 if ( codret.eq.0 ) then
158 call gbobal ( obterc, ityc, ioal )
160 cgn write(1,*) nompro, ioal, coergm
164 c 3. si l'objet est structure
167 if ( codret.eq.0 ) then
169 if ( ioal.eq.1 ) then
171 c 3.1. ==> nbojdl : nombre d'objets deja liberes
172 c nbojdd : nombre d'objets deja detaches
177 c 3.2. ==> construction du graphe de 'nomemc'
178 c * pour simple alloue
179 c > pour structure alloue
180 c = pour simple non alloue
181 c + pour structure non alloue
182 c - pour simple non defini
183 c < pour structure non defini
187 call gagpmc(obterc,iaux,jaux,chemin,lgchem,nbchem,impopt,igrp)
190 mess = ' gasgmc -> gagpmc -> codret : '
191 write(mess(29:30),'(i2)') igrp
195 cgn write(1,*) nompro, codret, coergm
197 c 3.3. ==> liberation de tous les objets du chemin
199 do 33 , iaux = nbchem , 1 , -1
201 c 3.3.1. ==> recherche de la profondeur du chemin
203 do 331 , jaux = 3 , jx , 2
204 if ((chemin(iaux,jaux)(1:1).eq.'*').or.
205 > (chemin(iaux,jaux)(1:1).eq.'=').or.
206 > (chemin(iaux,jaux)(1:1).eq.'+').or.
207 > (chemin(iaux,jaux)(1:1).eq.'-').or.
208 > (chemin(iaux,jaux)(1:1).eq.'<')) then
218 c 3.3.2. ==> exploration des branches de ce chemin, a l'envers
219 c on s'interesse a tous ceux que le graphe declare comme
220 c etant alloues. neanmoins, il faut verifier a chaque
221 c fois que l'objet est encore alloue car il a pu etre
222 c desalloue dans un chemin precedent.
223 c quand on arrive au bout du chemin, il faut detacher
224 c le dernier objet de la racine
226 do 333 , jaux = nj1 , 2 ,-2
228 objter = chemin(iaux,jaux)
231 if (objter.eq.sindef) then
234 if ((chemin(iaux,jaux+1)(1:1).eq.'=').or.
235 > (chemin(iaux,jaux+1)(1:1).eq.'+').or.
236 > (chemin(iaux,jaux+1)(1:1).eq.'-').or.
237 > (chemin(iaux,jaux+1)(1:1).eq.'<')) then
240 do 334 , kaux = 1,nbojdl
241 if (objlib(kaux).eq.objter) then
249 cgn write(1,*) nompro, 'call gblboj (objter)', coergm
250 if ( coergm.ne.0 ) then
257 objlib(nbojdl) = objter
261 if ( jaux.eq.2 .and. chemin(iaux,2).ne.sindef ) then
264 do 335 , kaux = 1,nbojdd
265 if (objdet(kaux).eq.chemin(iaux,1)) then
272 call gmdtoj ( obterc//'.'//chemin(iaux,1) , kaux )
273 cgn write (ulsort,*) obterc//'.'//chemin(iaux,1) , kaux, coergm
274 if ( kaux.ne.0 ) then
275 mess(1:17) = obterc//'.'//chemin(iaux,1)
281 objdet(nbojdd) = chemin(iaux,1)
292 c 4. si l'objet est simple : pas de chemin
295 elseif ( ioal.eq.2 ) then
300 c 5. l'objet n'est pas alloue
312 c 9. gestion des erreurs
317 #ifdef _DEBUG_HOMARD_
318 write (ulsort,*) '9. Gestions des erreurs ; codret = ', codret
319 write (ulsort,*) '9. Gestions des erreurs ; coergm = ', coergm
322 if ( codret.ne.0 ) then
325 write (ulsort,texte(langue,1)) 'Sortie', nompro
326 write (ulsort,texte(langue,6))
327 write (ulsort,*) nomemc
328 write (ulsort,texte(langue,4))
329 if ( abs(codret).le.6 .and. coergm.eq.0 ) then
330 iaux = 10+abs(codret)
331 write (ulsort,texte(langue,iaux))
333 write (ulsort,*) mess
340 90000 format (1x,70('='))