1 subroutine dehmaj ( option,
6 > ulsort, langue, codret )
7 c ______________________________________________________________________
11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
14 c aupres des huissiers de justice Simart et Lavoir a Clamart
15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
16 c aupres des huissiers de justice
17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
19 c HOMARD est une marque deposee d'Electricite de France
25 c ______________________________________________________________________
27 c traitement des DEcisions - Historique - Mis A Jour vraie
29 c ______________________________________________________________________
31 c but : mise a jour effective des historiques
32 c de maniere generale, l'historique des etats est un nombre a 2k
33 c chiffres. les k premiers decrivent l'etat de l'entite avant le
34 c processus de raffinement/deraffinement. les k derniers decrivent
35 c l'etat apres. a ce stade, nous sommes au depart du processus. il
36 c faut basculer l'etat "apres" pour le maillage n vers ce qui va etre
37 c l'etat "avant" pour le maillage n+1. les k premiers chiffres sont
38 c donc remplaces par les k derniers. les k derniers chiffres
39 c decrivent alors l'etat courant, une fois les entites de mise en
40 c conformite supprimees.
41 c ______________________________________________________________________
43 c . nom . e/s . taille . description .
44 c .____________________________________________________________________.
45 c . option . e . 1 . 0 : tri selon la conformite .
46 c . . . . 1 : transfert direct .
47 c . hetnoe . es . nbnoto . historique de l'etat des noeuds .
48 c . hetare . es . nbarto . historique de l'etat des aretes .
49 c . hettri . es . nbtrto . historique de l'etat des triangles .
50 c . hetqua . es . nbquto . historique de l'etat des quadrangles .
51 c . hettet . es . nbteto . historique de l'etat des tetraedres .
52 c . hethex . es . nbheto . historique de l'etat des hexaedres .
53 c . hetpen . es . nbpeto . historique de l'etat des pentaedres .
54 c . hetpyr . es . nbpyto . historique de l'etat des pyramides .
55 c . ulsort . e . 1 . unite logique de la sortie generale .
56 c . langue . e . 1 . langue des messages .
57 c . . . . 1 : francais, 2 : anglais .
58 c . codret . s . 1 . code de retour des modules .
59 c . . . . 0 : pas de probleme .
60 c . . . . 1 : probleme .
61 c ______________________________________________________________________
64 c 0. declarations et dimensionnement
67 c 0.1. ==> generalites
73 parameter ( nompro = 'DEHMAJ' )
94 integer hetnoe(nbnoto)
95 integer hetare(nbarto)
96 integer hettri(nbtrto)
97 integer hetqua(nbquto)
98 integer hettet(nbteto)
99 integer hethex(nbheto)
100 integer hetpen(nbpeto)
101 integer hetpyr(nbpyto)
103 integer ulsort, langue, codret
105 c 0.4. ==> variables locales
111 parameter (nbmess = 10 )
112 character*80 texte(nblang,nbmess)
113 c ______________________________________________________________________
121 #ifdef _DEBUG_HOMARD_
122 write (ulsort,texte(langue,1)) 'Entree', nompro
127 > '(5x,''Nombre d''''entites dont on modifie l''''historique'')'
130 > '(5x,''Number of entities whose history is modified'')'
132 10000 format(7x,a,' : ',i10)
137 write (ulsort,texte(langue,4))
138 #ifdef _DEBUG_HOMARD_
139 write (ulsort,10000) 'Option', option
143 c 1. historique des noeuds
145 c |------------------|----------------------------------------------|
146 c | etat | description |
147 c |------------------|----------------------------------------------|
148 c | 0 | noeud isole |
149 c | 1 | degre 1 = p1 |
150 c | 2 | degre 2 = p2 |
151 c | 3 | noeud de maille-point uniquement |
154 c |------------------|----------------------------------------------|
158 write (ulsort,10000) mess14(langue,4,-1), nbnoto
160 do 10 , iaux = 1 , nbnoto
162 etat = mod(hetnoe(iaux),10)
164 hetnoe(iaux) = etat * 11
169 c 2. historique des aretes
171 c |------------------|----------------------------------------------|
172 c | etat | description |
173 c |------------------|----------------------------------------------|
175 c | 2 | coupee en 2 et ses 2 filles sont actives |
176 c | 5 | inexistante |
177 c | 9 | coupee en 2 et un de ses filles est inactive |
178 c |------------------|----------------------------------------------|
182 write (ulsort,10000) mess14(langue,4,1), nbarto
184 do 20 , iaux = 1 , nbarto
186 etat = mod(hetare(iaux),10)
188 hetare(iaux) = etat * 11
193 c 3. historique des triangles
195 c |------------------|----------------------------------------------|
196 c | etat | description |
197 c |------------------|----------------------------------------------|
199 c | 1 | coupe en 2 par sa premiere arete |
200 c | 2 | coupe en 2 par sa deuxieme arete |
201 c | 3 | coupe en 2 par sa troisieme arete |
202 c | 4 | coupe en 4 et ses 4 fils sont actifs |
204 c | 6 | coupe en 4 et bascule de la premiere arete |
205 c | | ses 4 fils sont actifs |
206 c | 7 | idem avec la deuxieme arete |
207 c | 8 | idem avec la troisieme arete |
208 c | 9 | coupe en 4 et un de ses fils est inactif |
209 c |------------------|----------------------------------------------|
213 if ( nbtrto.ne.0 ) then
215 write (ulsort,10000) mess14(langue,4,2), nbtrto
219 do 30 , iaux = 1 , nbtrto
221 etat = mod(hettri(iaux),10)
223 if ( etat.lt.4 ) then
224 hettri(iaux) = etat * jaux
226 hettri(iaux) = etat * 11
234 c 4. historique des quadrangles
236 c |------------------|----------------------------------------------|
237 c | etat | description |
238 c |------------------|----------------------------------------------|
240 c | 4 | coupe en 4 et ses 4 fils sont actifs |
241 c | 21 | coupe en 2 quadrangles par les aretes 1 et 3 |
242 c | 22 | coupe en 2 quadrangles par les aretes 2 et 4 |
243 c | 31 | coupe en 3 triangles par son arete numero 1 |
244 c | 32 | coupe en 3 triangles par son arete numero 2 |
245 c | 33 | coupe en 3 triangles par son arete numero 2 |
246 c | 34 | coupe en 3 triangles par son arete numero 4 |
247 c | 41 | coupe en 3 quadrangles par les aretes 1 et 2 |
248 c | 42 | coupe en 3 quadrangles par les aretes 2 et 3 |
249 c | 43 | coupe en 3 quadrangles par les aretes 3 et 4 |
250 c | 44 | coupe en 3 quadrangles par les aretes 4 et 1 |
251 c | 55 | inexistant |
252 c | 99 | coupe en 4 et un de ses fils est inactif |
253 c |------------------|----------------------------------------------|
257 if ( nbquto.ne.0 ) then
259 write (ulsort,10000) mess14(langue,4,4), nbquto
263 do 40 , iaux = 1 , nbquto
265 etat = mod(hetqua(iaux),100)
267 if ( etat.ge.21 .and. etat.le.44 ) then
268 hetqua(iaux) = etat * jaux
270 hetqua(iaux) = etat * 101
278 c 5. historique des tetraedres
280 c |------------------|----------------------------------------------|
281 c | etat | description |
282 c |------------------|----------------------------------------------|
284 c | 2i i=1,2,3,4,5,6 | coupe en 2 par sa i-eme arete |
285 c | 4i i=1,2,3,4 | coupe en 4 par sa i-eme face |
286 c | 4i i=5,6,7 | coupe en 4 par la diagonale 1-6,2-5,3-4 |
287 c | 55 | inexistant |
288 c | 8i i=5,6,7 | coupe en 8 par la diagonale 1-6,2-5,3-4 |
289 c | 99 | coupe en 8 et un de ses fils est inactif |
290 c |------------------|----------------------------------------------|
294 if ( nbteto.ne.0 ) then
296 write (ulsort,10000) mess14(langue,4,3), nbteto
300 do 50 , iaux = 1 , nbteto
302 etat = mod(hettet(iaux),100)
304 if ( etat.lt.55 ) then
305 hettet(iaux) = etat * jaux
307 hettet(iaux) = etat * 101
315 c 6. historique des hexaedres
317 c |------------------|----------------------------------------------|
318 c | etat | description |
319 c |------------------|----------------------------------------------|
323 c | 9 | coupe en 8 et un de ses fils est inactif |
324 c | 11 | coupe par conformite |
325 c |------------------|----------------------------------------------|
329 if ( nbheto.ne.0 ) then
331 write (ulsort,10000) mess14(langue,4,6), nbheto
335 do 60 , iaux = 1 , nbheto
337 etat = mod(hethex(iaux),1000)
339 if ( etat.ge.11 ) then
340 hethex(iaux) = etat * jaux
342 hethex(iaux) = etat * 1001
350 c 7. historique des pyramides
352 c |------------------|----------------------------------------------|
353 c | etat | description |
354 c |------------------|----------------------------------------------|
356 c |------------------|----------------------------------------------|
360 if ( nbpyto.ne.0 ) then
362 write (ulsort,10000) mess14(langue,4,5), nbpyto
366 do 70 , iaux = 1 , nbpyto
368 etat = mod(hetpyr(iaux),100)
370 if ( etat.eq.0 ) then
371 hetpyr(iaux) = etat * jaux
381 c 8. historique des pentaedres
383 c |------------------|----------------------------------------------|
384 c | etat | description |
385 c |------------------|----------------------------------------------|
387 c | i i=1, ..., 6 | coupee par l'arete i |
388 c | i i=17, 18, 19 | coupee par l'arete i-10 |
389 c | i i=21, ..., 26 | coupee par 2 aretes tria & quad |
390 c | i i=31, ..., 36 | coupee par 2 aretes tria & tria |
391 c | i i=43, 44, 45 | coupee par une face quad |
392 c | i i=51, 52 | coupee par une face tria |
393 c | 55 | inexistant |
394 c | 80 | coupe en 8 |
395 c | 99 | coupe en 8 et un de ses fils est inactif |
396 c |------------------|----------------------------------------------|
400 if ( nbpeto.ne.0 ) then
402 write (ulsort,10000) mess14(langue,4,7), nbpeto
406 do 80 , iaux = 1 , nbpeto
408 etat = mod(hetpen(iaux),100)
410 if ( etat.lt.55 ) then
411 hetpen(iaux) = etat * jaux
413 hetpen(iaux) = etat * 101
426 if ( codret.ne.0 ) then
430 write (ulsort,texte(langue,1)) 'Sortie', nompro
431 write (ulsort,texte(langue,2)) codret
435 #ifdef _DEBUG_HOMARD_
436 write (ulsort,texte(langue,1)) 'Sortie', nompro