1 subroutine decr03 ( decfac, decare,
2 > hetare, posifa, facare,
7 > ulsort, langue, codret )
8 c ______________________________________________________________________
12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
15 c aupres des huissiers de justice Simart et Lavoir a Clamart
16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
17 c aupres des huissiers de justice
18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
20 c HOMARD est une marque deposee d'Electricite de France
26 c ______________________________________________________________________
28 c traitement des DEcisions - Contraintes de Raffinement - 03
30 c Bande de raffinement interdite
31 c ______________________________________________________________________
33 c . nom . e/s . taille . description .
34 c .____________________________________________________________________.
35 c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) .
37 c . decare . es . nbarto . decisions des aretes .
38 c . hetare . e . nbarto . historique de l'etat des aretes .
39 c . posifa . e . nbarto . pointeur sur tableau facare .
40 c . facare . e . nbfaar . liste des faces contenant une arete .
41 c . hettri . e . nbtrto . historique de l'etat des triangles .
42 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
43 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
44 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
45 c . listef . aux . nbquto/. auxiliaire sur les faces (quad. + tri.) .
47 c . afaire . es . 1 . que faire a la sortie .
48 c . . . . 0 : aucune action .
49 c . . . . 1 : refaire une iteration de l'algorithme .
50 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
51 c . langue . e . 1 . langue des messages .
52 c . . . . 1 : francais, 2 : anglais .
53 c . codret . es . 1 . code de retour des modules .
54 c . . . . 0 : pas de probleme .
55 c . . . . sinon : probleme .
56 c ______________________________________________________________________
59 c 0. declarations et dimensionnement
62 c 0.1. ==> generalites
68 parameter ( nompro = 'DECR03' )
83 integer decfac(-nbquto:nbtrto), decare(0:nbarto)
84 integer hetare(nbarto)
85 integer posifa(0:nbarto), facare(nbfaar)
86 integer hettri(nbtrto), aretri(nbtrto,3)
87 integer hetqua(nbquto), arequa(nbquto,4)
91 integer ulsort, langue, codret
93 c 0.4. ==> variables locales
96 integer iaux, ideb, ifin
97 integer laface, faced, etatfa
98 integer larelo, larete, iface
99 integer option, nbento, nbaret
100 integer nbface, nbarpb
101 integer infare(4), listar(4)
104 parameter ( nbmess = 30 )
105 character*80 texte(nblang,nbmess)
107 c 0.5. ==> initialisations
108 c ______________________________________________________________________
116 #ifdef _DEBUG_HOMARD_
117 write (ulsort,texte(langue,1)) 'Entree', nompro
121 texte(1,4) = '(5x,''Bande interdite.'')'
122 texte(1,5) = '(7x,''Nombre de faces a reconsiderer :'',i6,/)'
123 texte(1,6) = '(''. Probleme avec le '',a,i6)'
125 > '(a,''numero '',i6,'' : decision ='',i2,'', etat ='',i5)'
127 texte(2,4) = '(5x,''No band.'')'
128 texte(2,5) = '(7x,''Number of faces to deal with :'',i6,/)'
129 texte(2,6) = '(''. Problem with '',a,''#'',i6)'
131 > '(a,''#'',i6,'' : decision ='',i2,'', status ='',i5)'
139 write (ulsort,texte(langue,4))
142 c 2. on interdit les situations ou on aurait apparition d'une bande :
144 c . un triangle coupe dont aucun voisin ne serait decoupe
152 c .-------------. .-------------.
153 c . . .. . . . . .. . .
154 c . . . . . . . . . . . .
155 c . . . .. . . . . .. .
156 c . .-----. . . .-----. .
159 c -------------.------------- -------------.-------------
161 c . un triangle coupe dont un seul voisin est decoupe
176 c -------------.------.------
179 c . un quadrangle coupe dont aucun voisin ne serait decoupe
181 c -------------------------------------------
187 c -------------------------------------------
190 c . .-------------. .
193 c -------------------------------------------
199 c -------------------------------------------
201 c . un quadrangle coupe dont aucun voisin ne serait decoupe
204 c -------------------------------------------
210 c -------------------------------------------
213 c . .-------------.-------------.
216 c -------------------------------------------
222 c -------------------------------------------
224 c -------------------------------------------
230 c -------------------------------------------
233 c .-------------.-------------.-------------.
236 c -------------------------------------------
242 c -------------------------------------------
244 c Dans ces cas-la, il faut imposer le decoupage sur 1 ou 2 voisins
246 c On parcourt les faces coupees ou a couper. On compte combien elles
247 c possedent de faces voisines coupees ou a couper
252 do 2 , option = 2, 4, 2
254 #ifdef _DEBUG_HOMARD_
255 write (ulsort,*) mess14(langue,2,option)
258 if ( option.eq.2 ) then
266 do 20 , laface = 1 , nbento
268 if ( option.eq.2 ) then
269 etatfa = mod( hettri(laface) , 10 )
272 etatfa = mod( hetqua(laface) , 100 )
276 if ( ( etatfa.eq.0 .and. decfac(faced).eq.4 ) .or.
277 > etatfa.eq.4 .and. decfac(faced).ne.-1 ) then
278 #ifdef _DEBUG_HOMARD_
280 write (ulsort,texte(langue,7))mess14(langue,1,option),
281 > laface,decfac(faced),etatfa
284 c 2.1. ==> on parcourt chacune des aretes ; on remplit le tableau infare
285 c infare(ar) = 0 : une au moins des faces s'appuyant sur
286 c l'arete restera non decoupee
287 c infare(ar) = 2 : toutes les faces s'appuyant sur l'arete
288 c sont coupees ou a couper
289 c infare(ar) = -1 : l'arete est au bord
291 do 21 , larelo = 1 , nbaret
293 if ( option.eq.2 ) then
294 larete = aretri(laface,larelo)
296 larete = arequa(laface,larelo)
298 #ifdef _DEBUG_HOMARD_
299 write (ulsort,texte(langue,7))'.. '//mess14(langue,1,1),
300 > larete,decare(larete),hetare(larete)
302 ideb = posifa(larete-1)+1
303 ifin = posifa(larete)
305 if ( ideb.eq.ifin ) then
310 do 211 , ipos = ideb , ifin
312 if ( iface.ne.faced) then
313 if ( iface.gt.0 ) then
314 etatfa = mod( hettri(iface) , 10 )
316 etatfa = mod( hetqua(-iface) , 100 )
318 #ifdef _DEBUG_HOMARD_
319 write (ulsort,texte(langue,7))'.... '//mess14(langue,1,option),
320 > abs(iface),decfac(iface),etatfa
322 if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then
324 else if ( decfac(iface).eq.4 ) then
338 #ifdef _DEBUG_HOMARD_
339 write (ulsort,*) '==> infare : ',infare
343 c 2.2.1. ==> liste des aretes a traiter dans le cas du triangle
345 if ( option.eq.2 ) then
347 write (ulsort,*) 'pas glop'
350 c 2.2.2. ==> liste des aretes a traiter dans le cas cas du quadrangle
351 c on explore les aretes par paire : on intervient quand
352 c deux aretes en vis-a-vis sont a garder ou qu'une arete a
353 c garder est en face d'une arete de bord.
357 do 222 , iaux = 1 , 2
360 if ( infare(iaux).eq.0 .and.
361 > infare(iaux+2).eq.-1 ) then
363 elseif ( infare(iaux).eq.-1 .and.
364 > infare(iaux+2).eq.0 ) then
366 elseif ( infare(iaux).eq.0 .and.
367 > infare(iaux+2).eq.0 ) then
371 if ( larelo.ne.0 ) then
373 listar(nbarpb) = arequa(laface,larelo)
380 c 2.2.3. ==> liste des faces voisines de ces aretes a traiter
382 if ( nbarpb.ne.0 ) then
384 #ifdef _DEBUG_HOMARD_
385 write (ulsort,texte(langue,6)) mess14(langue,1,option),laface
386 write (ulsort,*)(listar(iaux),iaux=1,nbarpb)
389 do 223 , iaux = 1 , nbarpb
391 larete = listar(iaux)
393 #ifdef _DEBUG_HOMARD_
394 write (ulsort,texte(langue,7))'.. '//mess14(langue,1,1),
395 > larete,decare(larete),hetare(larete)
397 ideb = posifa(larete-1)+1
398 ifin = posifa(larete)
400 do 2231 , ipos = ideb , ifin
402 if ( iface.ne.faced) then
403 if ( iface.gt.0 ) then
404 etatfa = mod( hettri(iface) , 10 )
406 etatfa = mod( hetqua(-iface) , 100 )
407 #ifdef _DEBUG_HOMARD_
408 write (ulsort,texte(langue,7))'.... '//mess14(langue,1,4),
409 > -iface,decfac(iface),hetqua(-iface)
412 if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then
414 else if ( decfac(iface).eq.4 ) then
418 listef(nbface) = iface
434 c 3. modification des decisions
435 c attention : il faut le faire seulement a la toute fin, sinon on
436 c risque de propager le raffinement
438 #ifdef _DEBUG_HOMARD_
439 write (ulsort,90002) '6. modifications decfac ; codret', codret
442 if ( codret.eq.0 ) then
444 if ( nbface.ne.0 ) then
446 write (ulsort,texte(langue,5)) nbface
449 #ifdef _DEBUG_HOMARD_
450 write (ulsort,*)(listef(iaux),iaux=1,nbface)
453 do 31 , iaux = 1 , nbface
455 laface = listef(iaux)
456 if ( decfac(laface).eq.0 ) then
461 #ifdef _DEBUG_HOMARD_
463 write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' '
466 if ( laface.gt.0 ) then
467 do 311 , larelo = 1 , 3
468 larete = aretri(laface,larelo)
469 if ( decare(larete).eq.0 .or. decare(larete).eq.-1 ) then
471 infare(nbaret) = larete
475 do 312 , larelo = 1 , 4
476 larete = arequa(-laface,larelo)
477 if ( decare(larete).eq.0 .or. decare(larete).eq.-1 ) then
479 infare(nbaret) = larete
484 do 313 , larelo = 1 , nbaret
485 larete = infare(larelo)
486 if ( decare(larete).eq.0 ) then
487 if ( mod(hetare(larete),10).eq.0 ) then
490 elseif ( decare(larete).eq.-1 ) then
493 #ifdef _DEBUG_HOMARD_
494 write (ulsort,texte(langue,30))'decare', larete,decare(larete),' '
508 if ( codret.ne.0 ) then
512 write (ulsort,texte(langue,1)) 'Sortie', nompro
513 write (ulsort,texte(langue,2)) codret
517 #ifdef _DEBUG_HOMARD_
518 write (ulsort,texte(langue,1)) 'Sortie', nompro