1 subroutine dedin1 ( decare, decfac,
3 > hettri, aretri, filtri, nivtri,
4 > hetqua, arequa, filqua, nivqua,
5 > ulsort, langue, codret )
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c traitement des DEcisions - Deraffinement : Initialisation - option 1
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . decare . e/s . nbarto . decisions des aretes .
33 c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) .
35 c . posifa . e . nbarto . pointeur sur tableau facare .
36 c . facare . e . nbfaar . liste des faces contenant une arete .
37 c . hettri . e . nbtrto . historique de l'etat des triangles .
38 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
39 c . filtri . e . nbtrto . premier fils des triangles .
40 c . nivtri . e . nbtrto . niveau des triangles .
41 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
42 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
43 c . filqua . e . nbquto . fils des quadrangles .
44 c . nivqua . e . nbquto . niveau des quadrangles .
45 c . ulsort . e . 1 . unite logique de la sortie generale .
46 c . langue . e . 1 . langue des messages .
47 c . . . . 1 : francais, 2 : anglais .
48 c . codret . s . 1 . code de retour des modules .
49 c . . . . 0 : pas de probleme .
50 c . . . . 1 : probleme .
51 c ______________________________________________________________________
54 c 0. declarations et dimensionnement
57 c 0.1. ==> generalites
63 parameter ( nompro = 'DEDIN1' )
79 integer decare(0:nbarto)
80 integer decfac(-nbquto:nbtrto)
81 integer posifa(0:nbarto), facare(nbfaar)
82 integer hettri(nbtrto), aretri(nbtrto,3)
83 integer filtri(nbtrto), nivtri(nbtrto)
84 integer hetqua(nbquto), arequa(nbquto,4)
85 integer filqua(nbquto), nivqua(nbquto)
87 integer ulsort, langue, codret
89 c 0.4. ==> variables locales
91 integer laface, larete, niveau, numfac, etatfa, nuarvo, nufavo
92 integer iaux, ideb, ifin, jdeb, jfin, facvoi, iarelo
93 integer nivdeb, nivfin
94 integer nbare1, liare1(4), nbare2, liare2(4)
95 integer kaux, option, ipos
100 parameter ( nbmess = 30 )
101 character*80 texte(nblang,nbmess)
103 c 0.5. ==> initialisations
104 c ______________________________________________________________________
112 #ifdef _DEBUG_HOMARD_
113 write (ulsort,texte(langue,1)) 'Entree', nompro
124 c 2. on regarde tous les niveaux dans l'ordre croissant
127 #ifdef _DEBUG_HOMARD_
128 write (ulsort,90002) 'Etape 2', codret
131 nivdeb = max(nivinf-1,0)
133 do 100 , niveau = nivdeb , nivfin
135 #ifdef _DEBUG_HOMARD_
136 write (ulsort,texte(langue,3)) niveau
139 c boucle sur toutes les faces marquee "a reactiver"
140 c dans le niveau courant
142 do 2 , laface = -nbquto , nbtrto
144 if ( decfac(laface).eq.-1 ) then
146 c on regarde toutes les faces meres d'actives du niveau courant
149 if ( laface.gt.0 ) then
150 if ( nivtri(laface).eq.niveau ) then
151 etatfa = mod( hettri(laface) , 10 )
153 elseif ( laface.lt.0 ) then
155 if ( nivqua(iaux).eq.niveau ) then
156 etatfa = mod( hetqua(iaux) , 100 )
160 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
162 c 2.1. ==> liste des aretes de la face "a reactiver"
164 if ( laface.gt.0 ) then
166 do 211 , iarelo = 1 , nbare1
167 liare1(iarelo) = aretri(laface,iarelo)
172 do 212 , iarelo = 1 , nbare1
173 liare1(iarelo) = arequa(iaux,iarelo)
177 c 2.2. ==> Pour un triangle, si le premier triangle fils (central) est
178 c marque "a couper" (on ne teste ici que le premier fils
179 c car les trois autres sont testes ensuite), le triangle pere
180 c est a garder, de meme que ses aretes
182 if ( laface.gt.0 ) then
184 numfac = filtri(laface)
186 if ( decfac(numfac).gt.0 ) then
189 do 221 , iarelo = 1 , nbare1
190 larete = liare1(iarelo)
191 decare(larete) = max(0,decare(larete))
196 ideb = filtri(laface) + 1
201 ideb = - filqua(-laface) - 3
206 c 2.3. ==> si l'une des faces filles sur le bord de la face est marquee
207 c "a couper", on empeche le deraffinement de la mere et
208 c des faces voisines de la face-mere
210 do 231 , numfac = ideb , ifin
212 if ( decfac(numfac).gt.0 ) then
216 do 232 , iarelo = 1 , nbare1
218 larete = liare1(iarelo)
219 decare(larete) = max(0,decare(larete))
221 jdeb = posifa(larete-1) + 1
222 jfin = posifa(larete)
224 do 233 , nufavo = jdeb , jfin
226 facvoi = facare(nufavo)
229 if ( facvoi.gt.0 ) then
231 do 234 , nuarvo = 1 , nbare2
232 liare2(nuarvo) = aretri(facvoi,nuarvo)
237 do 235 , nuarvo = 1 , nbare2
238 liare2(nuarvo) = arequa(iaux,nuarvo)
242 do 236 , nuarvo = 1 , nbare2
243 decare(liare2(nuarvo)) =
244 > max(0,decare(liare2(nuarvo)))
264 c 3. on bascule "a garder" toutes les aretes des faces meres
265 c non actives "a garder". cette etape est indispensable au
266 c fonctionnement correct de la regle des deux voisins.
269 #ifdef _DEBUG_HOMARD_
270 write (ulsort,90002) 'Etape 3', codret
271 write (ulsort,texte(langue,11))
274 do 30 , laface = -nbquto , nbtrto
276 if ( decfac(laface).eq.0 ) then
279 if ( laface.gt.0 ) then
280 etatfa = mod( hettri(laface) , 10 )
281 if ( etatfa.ge.4 .and. etatfa.le.9 ) then
284 elseif ( laface.lt.0 ) then
286 etatfa = mod( hetqua(iaux) , 100 )
287 if ( etatfa.eq.4 .or. etatfa.eq.99 ) then
293 #ifdef _DEBUG_HOMARD_
294 if ( laface.gt.0 ) then
303 write (ulsort,texte(langue,29))
304 >mess14(langue,1,option),abs(laface),iaux,ipos,decfac(laface)
306 if ( laface.gt.0 ) then
308 do 31 , iarelo = 1 , nbare1
309 liare1(iarelo) = aretri(laface,iarelo)
314 do 32 , iarelo = 1 , nbare1
315 liare1(iarelo) = arequa(iaux,iarelo)
318 do 33 , iarelo = 1 , nbare1
319 kaux = liare1(iarelo)
320 if ( decare(kaux).eq.-1 ) then
322 #ifdef _DEBUG_HOMARD_
323 write (ulsort,texte(langue,30)) 'decare', kaux, decare(kaux),' '
337 if ( codret.ne.0 ) then
341 write (ulsort,texte(langue,1)) 'Sortie', nompro
342 write (ulsort,texte(langue,2)) codret
346 #ifdef _DEBUG_HOMARD_
347 write (ulsort,texte(langue,1)) 'Sortie', nompro