1 subroutine derco1 ( 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 1
32 c Application de la regle des deux voisins dans les cas :
33 c tyconf = 0 ; conforme
34 c tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees
35 c tyconf = -1 ; conforme avec boites
36 c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee
37 c ______________________________________________________________________
39 c . nom . e/s . taille . description .
40 c .____________________________________________________________________.
41 c . tyconf . e . 1 . 0 : conforme .
42 c . . . . 1 : non-conforme avec au minimum 2 aretes .
43 c . . . . non decoupees en 2 .
44 c . . . . 2 : non-conforme avec 1 seul noeud .
45 c . . . . pendant par arete .
46 c . . . . 3 : non-conforme fidele a l'indicateur .
47 c . . . . -1 : conforme, avec des boites pour les .
48 c . . . . quadrangles, hexaedres et pentaedres .
49 c . . . . -2 : non-conforme avec au maximum 1 arete .
50 c . . . . decoupee en 2 (boite pour les .
51 c . . . . quadrangles, hexaedres et pentaedres) .
52 c . . . . -2 : non-conforme avec au maximum 1 arete .
53 c . . . . decoupee en 2 (boite pour les .
54 c . . . . quadrangles, hexaedres et pentaedres) .
55 c . niveau . e . 1 . niveau en cours d'examen .
56 c . decare . es . nbarto . decisions des aretes .
57 c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) .
59 c . hetare . e . nbarto . historique de l'etat des aretes .
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 = 'DERCO1' )
101 integer decare(0:nbarto)
102 integer hetare(nbarto)
103 integer decfac(-nbquto:nbtrto)
104 integer posifa(0:nbarto), facare(nbfaar)
105 integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
106 integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
109 integer ulsort, langue, codret
111 c 0.4. ==> variables locales
113 integer facact, laface, nbfali
115 integer iaux, ideb, ifin, ifacli
116 integer nbaret, nbar00, anodec(4)
117 integer iarelo, iarete, iface
118 integer etatar, etatfa
119 integer nbare1, liare1(4)
122 parameter ( nbmess = 30 )
123 character*80 texte(nblang,nbmess)
125 c 0.5. ==> initialisations
126 c ______________________________________________________________________
134 #ifdef _DEBUG_HOMARD_
135 write (ulsort,texte(langue,1)) 'Entree', nompro
143 #ifdef _DEBUG_HOMARD_
144 write (ulsort,texte(langue,12)) niveau
146 #ifdef _DEBUG_HOMARD_
147 write (ulsort,90002) 'tyconf', tyconf
150 #ifdef _DEBUG_HOMARD_
152 do 1105 , iaux = 1 , nbquto
153 if ( decfac(-iaux).eq.4 ) ideb = ideb+1
154 cgn write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
155 cgn write (ulsort,90001) 'quadrangle', iaux,
156 cgn > arequa(iaux,1), arequa(iaux,2),
157 cgn > arequa(iaux,3), arequa(iaux,4)
159 write (ulsort,90002) 'quadrangles a decision 4', ideb
161 do 11051 , iaux = 1 , nbarto
162 if ( decare(iaux).eq.2 ) ideb = ideb+1
164 write (ulsort,90002) 'aretes a decision 2', ideb
166 #ifdef _DEBUG_HOMARD_
167 if ( nbquto.gt.0 ) then
168 iaux = min(nbquto,38)
169 write (ulsort,90112) 'nivqua', iaux, nivqua(iaux)
170 write (ulsort,90112) 'decfac', -iaux, decfac(-iaux)
171 write (ulsort,90001) 'aretes du quadrangle ', iaux,
172 >arequa(iaux,1), arequa(iaux,2),
173 >arequa(iaux,3), arequa(iaux,4)
174 write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
175 >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
176 >decare(arequa(iaux,3)), decare(arequa(iaux,4))
179 #ifdef _DEBUG_HOMARD_
180 if ( nbquto.gt.0 ) then
181 iaux = min(nbquto,10)
182 write (ulsort,90001) 'aretes du quadrangle ', iaux,
183 >arequa(iaux,1), arequa(iaux,2),
184 >arequa(iaux,3), arequa(iaux,4)
185 write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
186 >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
187 >decare(arequa(iaux,3)), decare(arequa(iaux,4))
188 iaux = min(nbquto,19)
189 write (ulsort,90001) 'aretes du quadrangle ', iaux,
190 >arequa(iaux,1), arequa(iaux,2),
191 >arequa(iaux,3), arequa(iaux,4)
192 write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
193 >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
194 >decare(arequa(iaux,3)), decare(arequa(iaux,4))
200 c initialisation vide de la liste de faces a examiner
204 c initialisation du nombre d'aretes decoupees possibles
205 c pour un quadrangle dans le cas de l'adaptation conforme
207 if ( tyconf.ge.0 ) then
214 c 2. Application de la regle des deux voisins
217 do 2 , laface = -nbquto , nbtrto
219 c on regarde toutes les faces actives du niveau courant
222 if ( laface.gt.0 ) then
223 if ( nivtri(laface).eq.niveau ) then
224 etatfa = mod( hettri(laface) , 10 )
226 elseif ( laface.lt.0 ) then
228 if ( nivqua(iaux).eq.niveau ) then
229 etatfa = mod( hetqua(iaux) , 100 )
233 if ( etatfa.eq.0 ) then
236 cgn write (ulsort,90001) 'face', facact
238 c debut du traitement de la face courante
239 c ***************************************
244 c on ne regarde que les faces "a garder"
246 if ( decfac(facact).eq.0 ) then
248 c 2.1. ==> on compte les aretes actives a garder et les aretes
249 c inactives a reactiver
251 if ( facact.gt.0 ) then
253 do 211 , iarelo = 1 , nbare1
254 liare1(iarelo) = aretri(facact,iarelo)
259 do 212 , iarelo = 1 , nbare1
260 liare1(iarelo) = arequa(iaux,iarelo)
265 do 213 , iarelo = 1 , nbare1
266 iarete = liare1(iarelo)
267 if ( decare(iarete).eq.0 ) then
268 etatar = mod( hetare(iarete) , 10 )
269 if ( etatar.eq.0 ) then
271 anodec(nbaret) = iarete
273 elseif ( decare(iarete).eq.-1 ) then
275 anodec(nbaret) = iarete
279 c 2.2. ==> aucune arete n'est ni "active a garder" ni "a reactiver"
280 c --------------------------------------------------------
281 c ==> on declare la face "a couper"
283 if ( nbaret.eq.0 ) then
286 #ifdef _DEBUG_HOMARD_
287 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
290 c 2.3. ==> une seule arete est une "active a garder" ou "a reactiver"
291 c ----------------------------------------------------------
292 c ==> on declare la face "a couper"
293 c . si l'arete est active, on la declare "a couper"
294 c . si l'arete est inactive, on la declare "a garder"
296 elseif ( nbaret.eq.1 ) then
299 #ifdef _DEBUG_HOMARD_
300 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
302 if ( mod(hetare(anodec(1)),10).eq.0 ) then
303 decare(anodec(1)) = 2
305 decare(anodec(1)) = 0
308 c on regarde toutes les faces qui s'appuient sur cette
309 c arete, on memorise celles qui sont actives "a garder"
311 ideb = posifa(anodec(1)-1)+1
312 ifin = posifa(anodec(1))
314 do 23 , ipos = ideb , ifin
316 if ( decfac(iface).eq.0 ) then
317 if ( iface.gt.0 ) then
318 etatfa = mod( hettri(iface) , 10 )
320 etatfa = mod( hetqua(-iface) , 100 )
322 if ( etatfa.eq.0 ) then
323 do 231 , ifacli = 1 , nbfali
324 if ( listfa(ifacli).eq.iface ) then
329 listfa(nbfali) = iface
335 c 2.4. ==> pour un quadrangle, deux aretes sont
336 c ------------------------------------
337 c des "actives a garder" ou "a reactiver" si on veut des boites
338 c -------------------------------------------------------------
340 elseif ( facact.lt.0 ) then
342 if ( nbaret.eq.nbar00 ) then
344 c on declare la face "a couper"
347 #ifdef _DEBUG_HOMARD_
348 if ( facact.eq.0 ) then
349 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
353 do 241 , iaux = 1 , 2
355 c . si l'arete est active, on la declare "a couper"
356 c . si l'arete est inactive, on la declare "a garder"
358 if ( mod(hetare(anodec(iaux)),10).eq.0 ) then
359 decare(anodec(iaux)) = 2
361 decare(anodec(iaux)) = 0
364 c on regarde toutes les faces qui s'appuient sur cette
365 c arete, on memorise celles qui sont actives "a garder"
367 ideb = posifa(anodec(iaux)-1)+1
368 ifin = posifa(anodec(iaux))
370 do 242 , ipos = ideb , ifin
372 if ( decfac(iface).eq.0 ) then
373 if ( iface.gt.0 ) then
374 etatfa = mod( hettri(iface) , 10 )
376 etatfa = mod( hetqua(-iface) , 100 )
378 if ( etatfa.eq.0 ) then
379 do 243 , ifacli = 1 , nbfali
380 if ( listfa(ifacli).eq.iface ) then
385 listfa(nbfali) = iface
399 c 2.5. ==> on passe a la face suivante de la liste
400 c ---------------------------------------
402 if ( nbfali .gt. 0 ) then
404 facact = listfa(nbfali)
414 #ifdef _DEBUG_HOMARD_
415 write (ulsort,*) 'sortie de ',nompro
416 do 11060 , iaux = 1 , nbarto
417 if ( iaux.eq.-17735 .or. iaux.eq.-877 ) then
418 write (ulsort,90001) '.. arete e/d', iaux,
419 > hetare(iaux), decare(iaux)
423 #ifdef _DEBUG_HOMARD_
425 do 1106 , iaux = 1 , nbquto
426 if ( decfac(-iaux).eq.4 ) ideb = ideb+1
427 cgn write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
428 cgn write (ulsort,90001) 'quadrangle', iaux,
429 cgn > arequa(iaux,1), arequa(iaux,2),
430 cgn > arequa(iaux,3), arequa(iaux,4)
432 write (ulsort,90002) 'quadrangle a decision 4', ideb
434 do 11061 , iaux = 1 , nbarto
435 if ( decare(iaux).eq.2 ) ideb = ideb+1
437 write (ulsort,90002) 'arete a decision 2', ideb
438 if ( nbquto.lt.0 ) then
439 iaux = min(nbquto,12)
440 write (ulsort,90112) 'decfac', -iaux, decfac(-iaux)
441 write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
442 >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
443 >decare(arequa(iaux,3)), decare(arequa(iaux,4))
444 cgn iaux = min(nbquto,10)
445 cgn write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
446 cgn >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
447 cgn >decare(arequa(iaux,3)), decare(arequa(iaux,4))
448 cgn iaux = min(nbquto,19)
449 cgn write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
450 cgn >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
451 cgn >decare(arequa(iaux,3)), decare(arequa(iaux,4))
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