1 subroutine dedcon ( tyconf, homolo,
4 > hetare, merare, arehom,
5 > hettri, aretri, nivtri,
6 > hetqua, arequa, nivqua,
8 > ulsort, langue, codret )
9 c ______________________________________________________________________
13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
16 c aupres des huissiers de justice Simart et Lavoir a Clamart
17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
18 c aupres des huissiers de justice
19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
21 c HOMARD est une marque deposee d'Electricite de France
27 c ______________________________________________________________________
29 c traitement des DEcisions - Deraffinement : CONtamination
31 c ______________________________________________________________________
33 c . nom . e/s . taille . description .
34 c .____________________________________________________________________.
35 c . tyconf . e . 1 . 0 : conforme (defaut) .
36 c . . . . 1 : non-conforme avec au minimum 2 aretes .
37 c . . . . non decoupees en 2 par face .
38 c . . . . 2 : non-conforme avec 1 seul noeud .
39 c . . . . pendant par arete .
40 c . . . . 3 : non-conforme fidele a l'indicateur .
41 c . . . . -1 : conforme, avec des boites pour les .
42 c . . . . quadrangles, hexaedres et pentaedres .
43 c . . . . -2 : non-conforme avec au maximum 1 arete .
44 c . . . . decoupee en 2 (boite pour les .
45 c . . . . quadrangles, hexaedres et pentaedres) .
46 c . homolo . e . 1 . presence d'homologue .
48 c . . . . 1 : il existe des noeuds homologues .
49 c . . . . 2 : il existe des aretes homologues .
50 c . . . . 3 : il existe des faces homologues .
51 c . decare . e/s . nbarto . decisions des aretes .
52 c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) .
54 c . posifa . e . nbarto . pointeur sur tableau facare .
55 c . facare . e . nbfaar . liste des faces contenant une arete .
56 c . hetare . e . nbarto . historique de l'etat des aretes .
57 c . merare . e . nbarto . mere des aretes .
58 c . arehom . e . nbarto . ensemble des aretes homologues .
59 c . hettri . e . nbtrto . historique de l'etat des triangles .
60 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
61 c . nivtri . e . nbtrto . niveau des triangles .
62 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
63 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
64 c . nivqua . e . nbquto . niveau des quadrangles .
65 c . listfa . t . * . liste de faces a considerer .
66 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
67 c . langue . e . 1 . langue des messages .
68 c . . . . 1 : francais, 2 : anglais .
69 c . codret . es . 1 . code de retour des modules .
70 c . . . . 0 : pas de probleme .
71 c . . . . 5 : mauvais type de code de calcul associe .
72 c ______________________________________________________________________
75 c 0. declarations et dimensionnement
78 c 0.1. ==> generalites
84 parameter ( nompro = 'DEDCON' )
98 integer tyconf, homolo
99 integer decare(0:nbarto)
100 integer decfac(-nbquto:nbtrto)
101 integer posifa(0:nbarto), facare(nbfaar)
102 integer hetare(nbarto), merare(nbarto), arehom(nbarto)
103 integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
104 integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
107 integer ulsort, langue, codret
109 c 0.4. ==> variables locales
112 #ifdef _DEBUG_HOMARD_
117 parameter ( nbmess = 30 )
118 character*80 texte(nblang,nbmess)
120 c 0.5. ==> initialisations
121 c ______________________________________________________________________
129 #ifdef _DEBUG_HOMARD_
130 write (ulsort,texte(langue,1)) 'Entree', nompro
139 #ifdef _DEBUG_HOMARD_
140 write (ulsort,90002) 'tyconf', tyconf
143 #ifdef _DEBUG_HOMARD_
144 cgn do 1105 , iaux = 1 , nbquto
145 cgn write (ulsort,90001) 'quadrangle', iaux,
146 cgn > arequa(iaux,1), arequa(iaux,2),
147 cgn > arequa(iaux,3), arequa(iaux,4)
151 #ifdef _DEBUG_HOMARD_
152 do 1103 , iaux = 1 , nbarto
153 if ( iaux.eq.2183 .or. iaux.eq.14556
154 > .or. iaux.eq.1658 .or. iaux.eq.1661 ) then
155 write (ulsort,90001) '.. arete e/d', iaux,
156 > hetare(iaux), decare(iaux)
160 #ifdef _DEBUG_HOMARD_
161 do 1104 , iaux = 1 , nbtrto
162 if ( iaux.eq.-830 .or. iaux.eq.-800) then
163 write (ulsort,90001) '.triangle', iaux,
164 > aretri(iaux,1), aretri(iaux,2),
166 write (ulsort,90002) 'niveau et decision',
167 > nivtri(iaux), decfac(iaux)
169 write (ulsort,90001) 'arete e/d', aretri(iaux,jaux),
170 > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux))
174 do 1105 , iaux = 1 , nbquto
175 if ( iaux.eq.-2311 ) then
176 cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or.
177 cgn > iaux.eq.333 .or. iaux.eq.1662.or.
178 cgn > iaux.eq.1658 .or. iaux.eq.1666 .or.
179 cgn > iaux.eq.729 .or. iaux.eq.721 ) then
180 write (ulsort,90001) 'quadrangle', iaux,
181 > arequa(iaux,1), arequa(iaux,2),
182 > arequa(iaux,3), arequa(iaux,4)
183 write (ulsort,90002) 'niveau et decision',
184 > nivqua(iaux), decfac(-iaux)
186 write (ulsort,90001) 'arete e/d', arequa(iaux,jaux),
187 > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux))
194 c 2. contamination des decisions pour le deraffinement
197 c 2.1. ==> cas sans entites homologues, sauf eventuellement des noeuds
199 if ( homolo.le.1 ) then
201 #ifdef _DEBUG_HOMARD_
202 write (ulsort,texte(langue,3)) 'DEDCO1', nompro
204 call dedco1 ( tyconf,
208 > hettri, aretri, nivtri,
209 > hetqua, arequa, nivqua,
211 > ulsort, langue, codret )
215 c 2.2. ==> cas avec homologue
217 #ifdef _DEBUG_HOMARD_
218 write (ulsort,texte(langue,3)) 'DEDCO2', nompro
220 call dedco2 ( tyconf,
223 > hetare, merare, arehom,
224 > hettri, aretri, nivtri,
225 > hetqua, arequa, nivqua,
227 > ulsort, langue, codret )
231 #ifdef _DEBUG_HOMARD_
232 write (ulsort,texte(langue,1)) 'Sortie', nompro
233 do 2103 , iaux = 1 , nbarto
234 if ( iaux.eq.2183 .or. iaux.eq.14556
235 > .or. iaux.eq.1658 .or. iaux.eq.1661 ) then
236 write (ulsort,90001) '.. arete e/d', iaux,
237 > hetare(iaux), decare(iaux)
240 do 2104 , iaux = 1 , nbtrto
241 if ( iaux.eq.-830 .or. iaux.eq.-833 .or. iaux.eq.-800) then
242 write (ulsort,90001) '.triangle', iaux,
243 > aretri(iaux,1), aretri(iaux,2),
245 write (ulsort,90002) '.. niveau et decision',
246 > nivtri(iaux), decfac(iaux)
248 write (ulsort,90001) '.. arete e/d', aretri(iaux,jaux),
249 > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux))
253 do 2105 , iaux = 1 , nbquto
254 if ( iaux.eq.-2311 ) then
255 cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or.
256 cgn > iaux.eq.333 .or. iaux.eq.1662 .or.
257 cgn > iaux.eq.1658 .or. iaux.eq.1666 .or.
258 cgn > iaux.eq.729 .or. iaux.eq.721 ) then
259 write (ulsort,90001) 'quadrangle', iaux,
260 > arequa(iaux,1), arequa(iaux,2),
261 > arequa(iaux,3), arequa(iaux,4)
262 write (ulsort,90002) 'de decision', decfac(-iaux)
264 write (ulsort,90001) 'arete e/d', arequa(iaux,jaux),
265 > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux))
275 if ( codret.ne.0 ) then
279 write (ulsort,texte(langue,1)) 'Sortie', nompro
280 write (ulsort,texte(langue,2)) codret
284 #ifdef _DEBUG_HOMARD_
285 write (ulsort,texte(langue,1)) 'Sortie', nompro