1 subroutine dedco2 ( tyconf,
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 - option 2
31 c prise en compte des homologues
32 c ______________________________________________________________________
34 c . nom . e/s . taille . description .
35 c .____________________________________________________________________.
36 c . tyconf . e . 1 . 0 : conforme (defaut) .
37 c . . . . 1 : non-conforme avec au minimum 2 aretes .
38 c . . . . non decoupees en 2 par face .
39 c . . . . 2 : non-conforme avec 1 seul noeud .
40 c . . . . pendant par arete .
41 c . . . . 3 : non-conforme fidele a l'indicateur .
42 c . . . . -1 : conforme, avec des boites pour les .
43 c . . . . quadrangles, hexaedres et pentaedres .
44 c . . . . -2 : non-conforme avec au maximum 1 arete .
45 c . . . . decoupee en 2 (boite pour les .
46 c . . . . quadrangles, hexaedres et pentaedres) .
47 c . decare . e/s . nbarto . decisions des aretes .
48 c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) .
50 c . posifa . e . nbarto . pointeur sur tableau facare .
51 c . facare . e . nbfaar . liste des faces contenant une arete .
52 c . hetare . e . nbarto . historique de l'etat des aretes .
53 c . merare . e . nbarto . mere des aretes .
54 c . arehom . e . nbarto . ensemble des aretes homologues .
55 c . hettri . e . nbtrto . historique de l'etat des triangles .
56 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
57 c . nivtri . e . nbtrto . niveau des triangles .
58 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
59 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
60 c . nivqua . e . nbquto . niveau des quadrangles .
61 c . listfa . t . * . liste de faces a considerer .
62 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
63 c . langue . e . 1 . langue des messages .
64 c . . . . 1 : francais, 2 : anglais .
65 c . codret . es . 1 . code de retour des modules .
66 c . . . . 0 : pas de probleme .
67 c ______________________________________________________________________
70 c 0. declarations et dimensionnement
73 c 0.1. ==> generalites
79 parameter ( nompro = 'DEDCO2' )
98 integer decare(0:nbarto)
99 integer decfac(-nbquto:nbtrto)
100 integer posifa(0:nbarto), facare(nbfaar)
101 integer hetare(nbarto), merare(nbarto), arehom(nbarto)
102 integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
103 integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
106 integer ulsort, langue, codret
108 c 0.4. ==> variables locales
110 integer nivdeb, nivfin, niveau
111 integer nbfali, laface, etatfa
112 integer facact, iarelo, iarete, etatar
113 integer nbaret, nbar00, anodec(4)
114 integer iaux, ideb, ifin
116 integer ipos, iface, ifacli, merear, jarelo
119 integer nbare1, liare1(4), nbare2, liare2(4), liare3(2)
120 #ifdef _DEBUG_HOMARD_
125 parameter ( nbmess = 30 )
126 character*80 texte(nblang,nbmess)
128 c 0.5. ==> initialisations
129 c ______________________________________________________________________
137 #ifdef _DEBUG_HOMARD_
138 write (ulsort,texte(langue,1)) 'Entree', nompro
148 #ifdef _DEBUG_HOMARD_
149 write (ulsort,90002) 'tyconf', tyconf
152 #ifdef _DEBUG_HOMARD_
153 cgn write (ulsort,*) 'en entree de ',nompro
154 cgn write (ulsort,*) 'quadrangle 5, de niveau ',nivqua(5)
155 cgn write (ulsort,*) 'decfac(q5) =',decfac(-5)
156 cgn write (ulsort,*) arequa(5,1),arequa(5,2),
157 cgn >arequa(5,3),arequa(5,4)
158 cgn write (ulsort,*) decare(arequa(5,1)),decare(arequa(5,2)),
159 cgn >decare(arequa(5,3)),decare(arequa(5,4))
160 cgn write (ulsort,*) hetare(arequa(5,1)),hetare(arequa(5,2)),
161 cgn >hetare(arequa(5,3)),hetare(arequa(5,4))
162 cgn write (ulsort,*) ' '
166 c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant
169 #ifdef _DEBUG_HOMARD_
170 write (ulsort,90002) 'Etape 3', codret
172 c initialisation vide de la liste de faces a examiner
176 c initialisation du nombre d'aretes decoupees possibles
177 c pour un quadrangle dans le cas de l'adaptation conforme
178 if ( tyconf.ge.0 ) then
185 nivfin = max(nivinf-1,0)
186 do 100 , niveau = nivdeb , nivfin , -1
188 #ifdef _DEBUG_HOMARD_
189 write (ulsort,texte(langue,12)) niveau
190 cgn write (ulsort,texte(langue,12)) niveau
191 cgn write (ulsort,*) 'quadrangle 5, de niveau ',nivqua(5)
192 cgn write (ulsort,*) 'decfac(q5) =',decfac(-5)
193 cgn write (ulsort,*) arequa(5,1),arequa(5,2),
194 cgn >arequa(5,3),arequa(5,4)
195 cgn write (ulsort,*) decare(arequa(5,1)),decare(arequa(5,2)),
196 cgn >decare(arequa(5,3)),decare(arequa(5,4))
197 cgn write (ulsort,*) hetare(arequa(5,1)),hetare(arequa(5,2)),
198 cgn >hetare(arequa(5,3)),hetare(arequa(5,4))
199 cgn write (ulsort,*) ' '
200 cgn write (ulsort,*) ' '
203 c 2.1. ==> traitement des faces pour la regle des deux voisins
204 c ===================================================
206 do 21 , laface = -nbquto , nbtrto
208 c on regarde les faces meres d'actives du niveau courant
211 if ( laface.gt.0 ) then
212 if ( nivtri(laface).eq.niveau ) then
213 etatfa = mod( hettri(laface) , 10 )
215 elseif ( laface.lt.0 ) then
217 if ( nivqua(iaux).eq.niveau ) then
218 etatfa = mod( hetqua(iaux) , 100 )
222 #ifdef _DEBUG_HOMARD_
223 if ( etatfa.gt.0 ) then
224 if ( laface.gt.0 ) then
231 write (ulsort,texte(langue,29)) mess14(langue,1,option),
232 > abs(laface), iaux,etatfa, decfac(laface)
236 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
242 c -------- debut du traitement de la face courante
243 c ***************************************
245 c on ne regarde que les faces "a reactiver"
247 if ( decfac(facact).eq.-1 ) then
249 #ifdef _DEBUG_HOMARD_
250 if ( facact.gt.0 ) then
257 write (ulsort,texte(langue,29))
258 >'. '//mess14(langue,1,option),abs(facact),
259 > iaux,-99999, decfac(facact)
262 c 2.1.1. ==> on compte les aretes inactives a garder
264 if ( facact.gt.0 ) then
266 do 2111 , iarelo = 1 , nbare1
267 liare1(iarelo) = aretri(facact,iarelo)
272 do 2112 , iarelo = 1 , nbare1
273 liare1(iarelo) = arequa(iaux,iarelo)
277 c nbaret = nombre d'aretes coupees en deux et a garder
278 c nbare2 = nombre d'aretes a reactiver
282 do 2113 , iarelo = 1 , nbare1
283 iarete = liare1(iarelo)
284 cgn write (ulsort,*) '... arete ',iarelo,' : ',iarete
285 if ( decare(iarete).eq.0 ) then
286 etatar = mod( hetare(iarete) , 10 )
287 if ( etatar.eq.2 ) then
292 anodec(nbare2) = iarete
293 liare2(nbare2) = iarelo
296 #ifdef _DEBUG_HOMARD_
297 write (ulsort,texte(langue,22)) nbaret, nbare2
300 if ( nbaret.eq.nbare1 ) then
302 c 2.1.2. ==> toutes les aretes sont coupees en deux et a garder
303 c --------------------------------------------------
304 c on declare la face "a garder"
308 #ifdef _DEBUG_HOMARD_
309 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
312 elseif ( nbaret.eq.(nbare1-1) ) then
314 c 2.1.3. ==> toutes les aretes sauf une sont coupees en deux et a garder
315 c -----------------------------------------------------------
316 c on declare la face et la derniere arete "a garder"
319 decare(anodec(1)) = 0
321 #ifdef _DEBUG_HOMARD_
322 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
323 write (ulsort,texte(langue,30))'decare',
324 >anodec(1),decare(anodec(1)),' (arete encore a reactiver)'
327 c on regarde toutes les faces qui s'appuient sur cette
328 c arete, on memorise celles qui sont non actives
331 ideb = posifa(anodec(1)-1)+1
332 ifin = posifa(anodec(1))
333 do 2131 , ipos = ideb , ifin
335 if ( decfac(iface).eq.-1 ) then
336 if ( iface.gt.0 ) then
337 etatfa = mod( hettri(iface) , 10 )
339 etatfa = mod( hetqua(-iface) , 100 )
341 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
342 do 2132 , ifacli = 1 , nbfali
343 if ( listfa(ifacli).eq.iface ) then
348 listfa(nbfali) = iface
354 c on regarde si l'arete a une homologue
357 if ( arehom(anodec(1)).ne.0 ) then
359 kaux = abs( arehom(anodec(1)) )
361 c l'arete homologue est declaree "a garder"
364 #ifdef _DEBUG_HOMARD_
365 write (ulsort,texte(langue,30))'decare',
366 >kaux,decare(kaux),' (homologue)'
369 c on regarde toutes les faces qui s'appuient sur cette
370 c arete, on memorise celles qui sont non actives "a
373 ideb = posifa(kaux-1) + 1
376 do 2134, ipos = ideb , ifin
378 if ( decfac(iface).eq.-1 ) then
379 if ( iface.gt.0 ) then
380 etatfa = mod( hettri(iface) , 10 )
382 etatfa = mod( hetqua(-iface) , 100 )
384 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
385 do 2135 , ifacli = 1 , nbfali
386 if ( listfa(ifacli).eq.iface ) then
391 listfa(nbfali) = iface
399 elseif ( facact.lt.0 ) then
401 if ( nbaret.eq.nbar00 ) then
403 c 2.1.4. ==> pour un quadrangle, deux aretes sont
404 c ------------------------------------
405 c des actives a garder si on veut des boites
406 c ------------------------------------------
407 c on declare la face et les 2 dernieres aretes "a garder"
411 #ifdef _DEBUG_HOMARD_
412 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
415 do 214 , iaux = 1 , 2
417 decare(anodec(iaux)) = 0
419 #ifdef _DEBUG_HOMARD_
420 write (ulsort,texte(langue,30))'decare',
421 >anodec(iaux),decare(anodec(iaux)),' (arete encore a reactiver)'
424 c on regarde toutes les faces qui s'appuient sur cette
425 c arete, on memorise celles qui sont non actives
428 ideb = posifa(anodec(iaux)-1)+1
429 ifin = posifa(anodec(iaux))
430 do 2141 , ipos = ideb , ifin
432 if ( decfac(iface).eq.-1 ) then
433 if ( iface.gt.0 ) then
434 etatfa = mod( hettri(iface) , 10 )
436 etatfa = mod( hetqua(-iface) , 100 )
438 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
439 do 2142 , ifacli = 1 , nbfali
440 if ( listfa(ifacli).eq.iface ) then
445 listfa(nbfali) = iface
451 c on regarde si l'arete a une homologue
454 if ( arehom(anodec(iaux)).ne.0 ) then
456 kaux = abs( arehom(anodec(iaux)) )
458 c l'arete homologue est declaree "a garder"
461 #ifdef _DEBUG_HOMARD_
462 write (ulsort,texte(langue,30))'decare',
463 >kaux,decare(kaux),' (homologue)'
466 c on regarde toutes les faces qui s'appuient sur cette
467 c arete, on memorise celles qui sont non actives "a
470 ideb = posifa(kaux-1) + 1
473 do 2144, ipos = ideb , ifin
475 if ( decfac(iface).eq.-1 ) then
476 if ( iface.gt.0 ) then
477 etatfa = mod( hettri(iface) , 10 )
479 etatfa = mod( hetqua(-iface) , 100 )
481 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
482 do 2145 , ifacli = 1 , nbfali
483 if ( listfa(ifacli).eq.iface ) then
488 listfa(nbfali) = iface
500 #ifdef _DEBUG_HOMARD_
501 c 2.1.n. ==> toutes les aretes sont a reactiver : OK
503 elseif ( nbare2.eq.nbare1 ) then
505 write (ulsort,texte(langue,15))
512 if ( nbfali.gt.0 ) then
514 c on passe a la face suivante de la liste
515 c ---------------------------------------
517 #ifdef _DEBUG_HOMARD_
518 write (ulsort,texte(langue,21)) nbfali
519 write (ulsort,*) (listfa(iaux),iaux=1,nbfali)
522 facact = listfa(nbfali)
532 c 2.2. ==> regle des ecarts de niveau
533 c ==========================
535 do 22 , laface = -nbquto , nbtrto
537 c on passe en revue les faces :
538 c . du niveau courant
543 if ( laface.gt.0 ) then
545 if ( nivtri(laface).eq.niveau ) then
546 etatfa = mod( hettri(laface) , 10 )
549 elseif ( laface.lt.0 ) then
552 if ( nivqua(iaux).eq.niveau ) then
553 etatfa = mod( hetqua(iaux) , 100 )
558 if ( etatfa.eq.0 ) then
560 c 2.2.1. ==> liste des aretes ayant une mere
562 if ( laface.gt.0 ) then
564 do 2211 , iarelo = 1 , nbare2
565 liare2(iarelo) = aretri(laface,iarelo)
570 do 2212 , iarelo = 1 , nbare2
571 liare2(iarelo) = arequa(iaux,iarelo)
576 do 2213 , iaux = 1 , nbare2
577 if ( merare(liare2(iaux)).gt.0 ) then
579 liare1(nbare1) = liare2(iaux)
583 c 2.2.2. ==> on parcourt les aretes retenues
585 do 222 , iarelo = 1 , nbare1
587 iarete = liare1(iarelo)
588 merear = merare(iarete)
590 c on explore les faces qui s'enroulent autour de
591 c l'arete merear et celles qui s'enroulent autour
592 c de son eventuelle homologue
595 if ( arehom(merear).eq.0 ) then
598 liare3(2) = abs(arehom(merear))
602 do 2220 , jaux = 1 , jfin
604 c on marque comme etant "a garder"
605 c celles qui sont "a reactiver"
607 ideb = posifa(liare3(jaux)-1)+1
608 ifin = posifa(liare3(jaux))
609 do 2221 , ipos = ideb , ifin
612 if ( decfac(iface).eq.-1 ) then
614 if ( iface.gt.0 ) then
615 etatfa = mod( hettri(iface) , 10 )
617 etatfa = mod( hetqua(-iface) , 100 )
619 if ( etatfa.eq.0 ) then
621 #ifdef _DEBUG_HOMARD_
622 write (ulsort,texte(langue,30)) 'decfac',
623 > iface, decfac(iface), ' (face voisine)'
625 if ( iface.gt.0 ) then
627 do 2222 , jarelo = 1 , nbare2
628 liare2(jarelo) = aretri(iface,jarelo)
633 do 2223 , jarelo = 1 , nbare2
634 liare2(jarelo) = arequa(iaux,jarelo)
637 do 2224 , jarelo = 1 , nbare2
638 jarete = liare2(jarelo)
639 if ( decare(jarete).eq.-1 ) then
641 #ifdef _DEBUG_HOMARD_
642 write (ulsort,texte(langue,30))'decare',
643 >jarete,decare(jarete),' '
645 if ( arehom(jarete).lt.0 ) then
646 if ( decare(abs(arehom(jarete))).eq.-1 )then
647 decare(abs(arehom(jarete))) = 0
648 #ifdef _DEBUG_HOMARD_
649 write (ulsort,texte(langue,30))'decare',
650 >abs(arehom(jarete)),decare(abs(arehom(jarete))),' (homologue)'
672 #ifdef _DEBUG_HOMARD_
677 if ( codret.eq.0 ) then
679 call dehova ( arehom, decare,
681 > ulsort, langue, codret )
690 if ( codret.ne.0 ) then
694 write (ulsort,texte(langue,1)) 'Sortie', nompro
695 write (ulsort,texte(langue,2)) codret
699 #ifdef _DEBUG_HOMARD_
700 write (ulsort,texte(langue,1)) 'Sortie', nompro