1 subroutine dedin2 ( decare, decfac,
4 > hettri, aretri, filtri, nivtri,
5 > hetqua, arequa, filqua, nivqua,
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 - Deraffinement : Initialisation - option 2
29 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . decare . e/s . nbarto . decisions des aretes .
34 c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) .
36 c . posifa . e . nbarto . pointeur sur tableau facare .
37 c . facare . e . nbfaar . liste des faces contenant une arete .
38 c . arehom . e . nbarto . ensemble des aretes homologues .
39 c . hettri . e . nbtrto . historique de l'etat des triangles .
40 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
41 c . filtri . e . nbtrto . premier fils des triangles .
42 c . nivtri . e . nbtrto . niveau des triangles .
43 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
44 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
45 c . filqua . e . nbquto . fils des quadrangles .
46 c . nivqua . e . nbquto . niveau des quadrangles .
47 c . ulsort . e . 1 . unite logique de la sortie generale .
48 c . langue . e . 1 . langue des messages .
49 c . . . . 1 : francais, 2 : anglais .
50 c . codret . s . 1 . code de retour des modules .
51 c . . . . 0 : pas de probleme .
52 c . . . . 1 : probleme .
53 c ______________________________________________________________________
56 c 0. declarations et dimensionnement
59 c 0.1. ==> generalites
65 parameter ( nompro = 'DEDIN2' )
81 integer decare(0:nbarto)
82 integer decfac(-nbquto:nbtrto)
83 integer posifa(0:nbarto), facare(nbfaar)
84 integer arehom(nbarto)
85 integer hettri(nbtrto), aretri(nbtrto,3)
86 integer filtri(nbtrto), nivtri(nbtrto)
87 integer hetqua(nbquto), arequa(nbquto,4)
88 integer filqua(nbquto), nivqua(nbquto)
90 integer ulsort, langue, codret
92 c 0.4. ==> variables locales
94 integer laface, larete, niveau, numfac, etatfa, nuarvo, nufavo
95 integer iaux, ideb, ifin, jdeb, jfin, arevoi, facvoi, iarelo
96 integer nivdeb, nivfin
97 integer nbare1, liare1(4), nbare2, liare2(4)
103 parameter ( nbmess = 30 )
104 character*80 texte(nblang,nbmess)
106 c 0.5. ==> initialisations
107 c ______________________________________________________________________
115 #ifdef _DEBUG_HOMARD_
116 write (ulsort,texte(langue,1)) 'Entree', nompro
127 c 2. on regarde tous les niveaux dans l'ordre croissant
130 nivdeb = max(nivinf-1,0)
132 do 100 , niveau = nivdeb , nivfin
134 #ifdef _DEBUG_HOMARD_
135 write (ulsort,texte(langue,3)) niveau
138 c boucle sur toutes les faces marquee "a reactiver"
139 c dans le niveau courant
141 do 2 , laface = -nbquto , nbtrto
143 if ( decfac(laface).eq.-1 ) then
145 c on regarde toutes les faces meres d'actives du niveau courant
148 if ( laface.gt.0 ) then
149 if ( nivtri(laface).eq.niveau ) then
150 etatfa = mod( hettri(laface) , 10 )
152 elseif ( laface.lt.0 ) then
154 if ( nivqua(iaux).eq.niveau ) then
155 etatfa = mod( hetqua(iaux) , 100 )
159 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
161 c 2.1. ==> liste des aretes de la face "a reactiver"
163 if ( laface.gt.0 ) then
165 do 211 , iarelo = 1 , nbare1
166 liare1(iarelo) = aretri(laface,iarelo)
171 do 212 , iarelo = 1 , nbare1
172 liare1(iarelo) = arequa(iaux,iarelo)
176 c 2.2. ==> Pour un triangle, si le premier triangle fils (central) est
177 c marque "a couper" (on ne teste ici que le premier fils
178 c car les trois autres sont testes ensuite), le triangle pere
179 c est a garder, de meme que ses aretes
181 if ( laface.gt.0 ) then
183 numfac = filtri(laface)
185 if ( decfac(numfac).gt.0 ) then
187 decfac(laface) = max(0,decfac(laface))
188 do 221 , iarelo = 1 , nbare1
189 larete = liare1(iarelo)
190 decare(larete) = max(0,decare(larete))
191 if ( arehom(larete).ne.0 ) then
192 decare(abs(arehom(larete))) =
193 > max(0,decare(abs(arehom(larete))))
199 ideb = filtri(laface) + 1
204 ideb = - filqua(-laface) - 3
209 c 2.3. ==> si l'une des faces filles sur le bord de la face est marquee
210 c "a couper", on empeche le deraffinement de la mere et
211 c des faces voisines de la face-mere
213 do 231 , numfac = ideb , ifin
215 if ( decfac(numfac).gt.0 ) then
219 do 232 , iarelo = 1 , nbare1
221 larete = liare1(iarelo)
222 decare(larete) = max(0,decare(larete))
223 if ( arehom(larete).ne.0 ) then
224 decare(abs(arehom(larete))) =
225 > max(0,decare(abs(arehom(larete))))
228 jdeb = posifa(larete-1) + 1
229 jfin = posifa(larete)
231 do 233 , nufavo = jdeb , jfin
233 facvoi = facare(nufavo)
236 if ( facvoi.gt.0 ) then
238 do 234 , nuarvo = 1 , nbare2
239 liare2(nuarvo) = aretri(facvoi,nuarvo)
244 do 235 , nuarvo = 1 , nbare2
245 liare2(nuarvo) = arequa(iaux,nuarvo)
249 do 236 , nuarvo = 1 , nbare2
250 arevoi = liare2(nuarvo)
251 decare(arevoi) = max(0,decare(arevoi))
252 if ( arehom(arevoi).ne.0 ) then
253 decare(abs(arehom(arevoi))) =
254 > max(0,decare(abs(arehom(arevoi))))
275 c 3. on bascule "a garder" toutes les aretes des faces meres
276 c non actives "a garder". cette etape est indispensable au
277 c fonctionnement correct de la regle des deux voisins.
278 c Il faut le transmettre aux eventuelles aretes homologues
281 #ifdef _DEBUG_HOMARD_
282 write (ulsort,90002) 'Etape 3', codret
285 do 30 , laface = -nbquto , nbtrto
287 if ( decfac(laface).eq.0 ) then
290 if ( laface.gt.0 ) then
291 etatfa = mod( hettri(laface) , 10 )
292 if ( etatfa.ge.4 .and. etatfa.le.9 ) then
295 elseif ( laface.lt.0 ) then
297 etatfa = mod( hetqua(iaux) , 100 )
298 if ( etatfa.eq.4 .or. etatfa.eq.99 ) then
304 #ifdef _DEBUG_HOMARD_
305 if ( laface.gt.0 ) then
312 write (ulsort,texte(langue,29)) mess14(langue,1,option),
313 > abs(laface), iaux,etatfa, decfac(laface)
315 if ( laface.gt.0 ) then
317 do 31 , iarelo = 1 , nbare1
318 liare1(iarelo) = aretri(laface,iarelo)
323 do 32 , iarelo = 1 , nbare1
324 liare1(iarelo) = arequa(iaux,iarelo)
327 do 33 , iarelo = 1 , nbare1
328 kaux = liare1(iarelo)
329 if ( decare(kaux).eq.-1 ) then
331 #ifdef _DEBUG_HOMARD_
332 write (ulsort,texte(langue,30)) 'decare', kaux, decare(kaux),' '
335 if ( arehom(kaux).ne.0 ) then
336 if ( decare(abs(arehom(kaux))).eq.-1 ) then
337 decare(abs(arehom(kaux))) = 0
338 #ifdef _DEBUG_HOMARD_
339 write (ulsort,texte(langue,30)) 'decare',
340 > abs(arehom(kaux)), decare(abs(arehom(kaux))), '(homologue)'
355 if ( codret.ne.0 ) then
359 write (ulsort,texte(langue,1)) 'Sortie', nompro
360 write (ulsort,texte(langue,2)) codret
364 #ifdef _DEBUG_HOMARD_
365 write (ulsort,texte(langue,1)) 'Sortie', nompro