1 subroutine derco4 ( tyconf,
6 > hettri, aretri, nivtri,
7 > hetqua, arequa, nivqua,
9 > ulsort, langue, codret )
10 c ______________________________________________________________________
14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
17 c aupres des huissiers de justice Simart et Lavoir a Clamart
18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
19 c aupres des huissiers de justice
20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
22 c HOMARD est une marque deposee d'Electricite de France
28 c ______________________________________________________________________
30 c traitement des DEcisions - Raffinement : COntamination - option 4
32 c Application de la regle des deux voisins :
33 c pilraf = 1 ou 2. libre
34 c pilraf = 3. non-conforme avec 1 arete decoupee unique par element
35 c en presence d'aretes et/ou de faces homologues :
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . tyconf . e . 1 . 0 : conforme .
41 c . . . . 1 : non-conforme avec au minimum 2 aretes .
42 c . . . . non decoupees en 2 .
43 c . . . . 2 : non-conforme avec 1 seul noeud .
44 c . . . . pendant par arete .
45 c . . . . 3 : non-conforme fidele a l'indicateur .
46 c . . . . -1 : conforme, avec des boites pour les .
47 c . . . . quadrangles, hexaedres et pentaedres .
48 c . . . . -2 : non-conforme avec au maximum 1 arete .
49 c . . . . decoupee en 2 (boite pour les .
50 c . . . . quadrangles, hexaedres et pentaedres) .
51 c . . . . -2 : non-conforme avec au maximum 1 arete .
52 c . . . . decoupee en 2 (boite pour les .
53 c . . . . quadrangles, hexaedres et pentaedres) .
54 c . niveau . e . 1 . niveau en cours d'examen .
55 c . decare . es . nbarto . decisions des aretes .
56 c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) .
58 c . hetare . e . nbarto . historique de l'etat des aretes .
59 c . arehom . e . nbarto . ensemble des aretes homologues .
60 c . posifa . e . nbarto . pointeur sur tableau facare .
61 c . facare . e . nbfaar . liste des faces contenant une arete .
62 c . hettri . e . nbtrto . historique de l'etat des triangles .
63 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
64 c . nivtri . e . nbtrto . niveau des triangles .
65 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
66 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
67 c . nivqua . e . nbquto . niveau des quadrangles .
68 c . listfa . t . * . liste de faces a considerer .
69 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
70 c . langue . e . 1 . langue des messages .
71 c . . . . 1 : francais, 2 : anglais .
72 c . codret . es . 1 . code de retour des modules .
73 c . . . . 0 : pas de probleme .
74 c ______________________________________________________________________
77 c 0. declarations et dimensionnement
80 c 0.1. ==> generalites
86 parameter ( nompro = 'DERCO4' )
101 integer decare(0:nbarto)
102 integer hetare(nbarto)
103 integer decfac(-nbquto:nbtrto)
104 integer posifa(0:nbarto), facare(nbfaar)
105 integer arehom(nbarto)
106 integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
107 integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
110 integer ulsort, langue, codret
112 c 0.4. ==> variables locales
114 integer facact, laface, nbfali
116 integer iaux, ideb, ifin, ifacli
117 integer nbaret, nbar00, anodec(4)
119 integer iarelo, iarete, iface
120 integer etatar, etatfa
121 integer nbare1, liare1(4)
124 parameter ( nbmess = 30 )
125 character*80 texte(nblang,nbmess)
127 c 0.5. ==> initialisations
128 c ______________________________________________________________________
136 #ifdef _DEBUG_HOMARD_
137 write (ulsort,texte(langue,1)) 'Entree', nompro
145 #ifdef _DEBUG_HOMARD_
146 write (ulsort,texte(langue,12)) niveau
151 c initialisation vide de la liste de faces a examiner
155 c initialisation du nombre d'aretes autorisees pour un quadrangle
157 if ( tyconf.eq.0 ) then
164 c 2. Application de la regle des deux voisins
167 do 2 , laface = -nbquto , nbtrto
169 c on regarde toutes les faces actives du niveau courant
172 if ( laface.gt.0 ) then
173 if ( nivtri(laface).eq.niveau ) then
174 etatfa = mod( hettri(laface) , 10 )
176 elseif ( laface.lt.0 ) then
178 if ( nivqua(iaux).eq.niveau ) then
179 etatfa = mod( hetqua(iaux) , 100 )
183 if ( etatfa.eq.0 ) then
187 c debut du traitement de la face courante
188 c ***************************************
193 c on ne regarde que les faces "a garder"
195 if ( decfac(facact).eq.0 ) then
197 c 2.1. ==> on compte les aretes actives a garder et les aretes
198 c inactives a reactiver
200 if ( facact.gt.0 ) then
202 do 211 , iarelo = 1 , nbare1
203 liare1(iarelo) = aretri(facact,iarelo)
208 do 212 , iarelo = 1 , nbare1
209 liare1(iarelo) = arequa(iaux,iarelo)
214 do 213 , iarelo = 1 , nbare1
215 iarete = liare1(iarelo)
216 if ( decare(iarete).eq.0 ) then
217 etatar = mod( hetare(iarete) , 10 )
218 if ( etatar.eq.0 ) then
220 anodec(nbaret) = iarete
222 elseif ( decare(iarete).eq.-1 ) then
224 anodec(nbaret) = iarete
228 c 2.2. ==> aucune arete n'est une active a garder
229 c ------------------------------------
230 c ==> on declare la face "a couper"
232 if ( nbaret.eq.0 ) then
236 c 2.3. ==> une seule arete est une active a garder
237 c ---------------------------------------
239 elseif ( nbaret.eq.1 ) then
241 c 2.3.1. ==> on declare la face "a couper"
242 c . si l'arete est active, on la declare "a couper"
243 c . si l'arete est inactive, on la declare "a garder"
246 if ( mod(hetare(anodec(1)),10).eq.0 ) then
247 decare(anodec(1)) = 2
249 decare(anodec(1)) = 0
252 c on regarde toutes les faces qui s'appuient sur cette
253 c arete, on memorise celles qui sont actives "a garder"
255 ideb = posifa(anodec(1)-1)+1
256 ifin = posifa(anodec(1))
258 do 231 , ipos = ideb , ifin
260 if ( decfac(iface).eq.0 ) then
261 if ( iface.gt.0 ) then
262 etatfa = mod( hettri(iface) , 10 )
264 etatfa = mod( hetqua(-iface) , 100 )
266 if ( etatfa.eq.0 ) then
267 do 2311 , ifacli = 1 , nbfali
268 if ( listfa(ifacli).eq.iface ) then
273 listfa(nbfali) = iface
279 c 2.3.2. ==> on regarde si l'arete a une homologue
281 if ( arehom(anodec(1)) .ne. 0 ) then
283 kaux = abs( arehom(anodec(1)) )
285 c . si l'arete homologue est active, on la declare "a couper"
286 c . si l'arete homologue est inactive, on la declare "a garder"
288 if ( mod(hetare(kaux),10).eq.0 ) then
294 c on regarde toutes les faces qui s'appuient sur cette
295 c arete, on memorise celles qui sont actives a "garder"
297 ideb = posifa(kaux-1) + 1
300 do 232, ipos = ideb , ifin
302 if ( decfac(iface).eq.0 ) then
303 if ( iface.gt.0 ) then
304 etatfa = mod( hettri(iface) , 10 )
306 etatfa = mod( hetqua(-iface) , 100 )
308 if ( etatfa.eq.0 ) then
309 do 2321 , ifacli = 1 , nbfali
310 if ( listfa(ifacli).eq.iface ) then
315 listfa(nbfali) = iface
323 c 2.4. ==> pour un quadrangle, deux aretes sont
324 c ------------------------------------
325 c des actives a garder si on veut des boites
326 c ------------------------------------------
328 elseif ( facact.lt.0 ) then
330 if ( nbaret.eq.nbar00 ) then
332 c on declare la face "a couper"
338 c 2.4.1. ==> . si l'arete est active, on la declare "a couper"
339 c . si l'arete est inactive, on la declare "a garder"
341 if ( mod(hetare(anodec(iaux)),10).eq.0 ) then
342 decare(anodec(iaux)) = 2
344 decare(anodec(iaux)) = 0
347 c on regarde toutes les faces qui s'appuient sur cette
348 c arete, on memorise celles qui sont actives "a garder"
350 ideb = posifa(anodec(iaux)-1)+1
351 ifin = posifa(anodec(iaux))
353 do 241 , ipos = ideb , ifin
355 if ( decfac(iface).eq.0 ) then
356 if ( iface.gt.0 ) then
357 etatfa = mod( hettri(iface) , 10 )
359 etatfa = mod( hetqua(-iface) , 100 )
361 if ( etatfa.eq.0 ) then
362 do 2412 , ifacli = 1 , nbfali
363 if ( listfa(ifacli).eq.iface ) then
368 listfa(nbfali) = iface
374 c 2.4.2. ==> . si l'arete a une homolgue
376 if ( arehom(anodec(iaux)) .ne. 0 ) then
378 kaux = abs( arehom(anodec(iaux)) )
380 c . si l'arete homologue est active, on la declare "a couper"
381 c . si l'arete homologue est inactive, on la declare "a garder"
383 if ( mod(hetare(kaux),10).eq.0 ) then
389 c on regarde toutes les faces qui s'appuient sur cette
390 c arete, on memorise celles qui sont actives a "garder"
392 ideb = posifa(kaux-1) + 1
395 do 242, ipos = ideb , ifin
397 if ( decfac(iface).eq.0 ) then
398 if ( iface.gt.0 ) then
399 etatfa = mod( hettri(iface) , 10 )
401 etatfa = mod( hetqua(-iface) , 100 )
403 if ( etatfa.eq.0 ) then
404 do 2421 , ifacli = 1 , nbfali
405 if ( listfa(ifacli).eq.iface ) then
410 listfa(nbfali) = iface
426 c 2.5. ==> on passe a la face suivante de la liste
427 c ---------------------------------------
429 if ( nbfali .gt. 0 ) then
431 facact = listfa(nbfali)
441 #ifdef _DEBUG_HOMARD_
446 if ( codret.eq.0 ) then
448 call dehova ( arehom, decare,
450 > ulsort, langue, codret )
459 if ( codret.ne.0 ) then
463 write (ulsort,texte(langue,1)) 'Sortie', nompro
464 write (ulsort,texte(langue,2)) codret
468 #ifdef _DEBUG_HOMARD_
469 write (ulsort,texte(langue,1)) 'Sortie', nompro