1 subroutine dedco1 ( tyconf,
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 1
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 . hettri . e . nbtrto . historique de l'etat des triangles .
55 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
56 c . nivtri . e . nbtrto . niveau des triangles .
57 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
58 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
59 c . nivqua . e . nbquto . niveau des quadrangles .
60 c . listfa . t . * . liste de faces a considerer .
61 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
62 c . langue . e . 1 . langue des messages .
63 c . . . . 1 : francais, 2 : anglais .
64 c . codret . es . 1 . code de retour des modules .
65 c . . . . 0 : pas de probleme .
66 c ______________________________________________________________________
69 c 0. declarations et dimensionnement
72 c 0.1. ==> generalites
78 parameter ( nompro = 'DEDCO1' )
95 integer decare(0:nbarto)
96 integer decfac(-nbquto:nbtrto)
97 integer posifa(0:nbarto), facare(nbfaar)
98 integer hetare(nbarto), merare(nbarto)
99 integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
100 integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
103 integer ulsort, langue, codret
105 c 0.4. ==> variables locales
107 integer nivdeb, nivfin, niveau
108 integer nbfali, laface, etatfa
109 integer facact, iarelo, iarete, etatar
110 integer nbaret, nbar00, anodec(4)
111 integer iaux, ideb, ifin
112 integer ipos, iface, ifacli, merear, jarelo
114 integer nbare1, liare1(4), nbare2, liare2(4)
115 #ifdef _DEBUG_HOMARD_
121 parameter ( nbmess = 30 )
122 character*80 texte(nblang,nbmess)
124 c 0.5. ==> initialisations
125 c ______________________________________________________________________
133 #ifdef _DEBUG_HOMARD_
134 write (ulsort,texte(langue,1)) 'Entree', nompro
144 #ifdef _DEBUG_HOMARD_
145 write (ulsort,90002) 'tyconf', tyconf
148 #ifdef _DEBUG_HOMARD_
150 write (ulsort,90003) 'Entree de ',nompro
151 do 1106 , iaux = 1 , nbtrto, -1
152 write (ulsort,90015) 'triangle', iaux, ' decision,niveau,etat',
153 > decfac(iaux), nivtri(iaux), hettri(iaux)
154 write (ulsort,90002) 'aretes', aretri(iaux,1),
155 > aretri(iaux,2), aretri(iaux,3)
156 write (ulsort,90002) 'decare', decare(aretri(iaux,1)),
157 > decare(aretri(iaux,2)), decare(aretri(iaux,3))
160 do 1105 , iaux = 1 , nbquto
161 if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then
162 write (ulsort,90015) 'quadrangle', iaux, ' decision,niveau,etat',
163 > decfac(-iaux), nivqua(iaux), hetqua(iaux)
164 write (ulsort,90002) 'aretes',
165 > arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4)
166 write (ulsort,90002) 'decare',
167 > decare(arequa(iaux,1)), decare(arequa(iaux,2)),
168 > decare(arequa(iaux,3)), decare(arequa(iaux,4))
170 if ( jaux.eq.10) then
176 do 1104 , iaux = 1 , nbarto, -1
177 write (ulsort,90001) 'decision arete', iaux, decare(iaux)
180 do 1108 , iaux = 1 , min(2,nbquto), -1
181 write (ulsort,90001) 'decfac pour quadrangle ', iaux,
183 write (ulsort,90001) 'aretes du quadrangle ', iaux,
184 >arequa(iaux,1), arequa(iaux,2),
185 >arequa(iaux,3), arequa(iaux,4)
186 write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
187 >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
188 >decare(arequa(iaux,3)), decare(arequa(iaux,4))
193 c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant
196 #ifdef _DEBUG_HOMARD_
197 write (ulsort,90002) 'Etape 2', codret
199 c initialisation vide de la liste de faces a examiner
203 c initialisation du nombre d'aretes decoupees possibles
204 c pour un quadrangle dans le cas de l'adaptation conforme
205 if ( tyconf.ge.0 ) then
212 nivfin = max(nivinf-1,0)
213 do 100 , niveau = nivdeb , nivfin , -1
215 #ifdef _DEBUG_HOMARD_
216 write (ulsort,texte(langue,12)) niveau
219 c 2.1. ==> traitement des faces pour la regle des deux voisins
220 c ===================================================
221 c elle s'applique aux cas d'adaptation :
222 c tyconf = 0 ; conforme
223 c tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees
224 c tyconf = -1 ; conforme avec boites
225 c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee
227 if ( tyconf.le.1 ) then
229 do 21 , laface = -nbquto , nbtrto
231 c on regarde les faces meres d'actives du niveau courant
234 if ( laface.gt.0 ) then
235 if ( nivtri(laface).eq.niveau ) then
236 etatfa = mod( hettri(laface) , 10 )
238 elseif ( laface.lt.0 ) then
240 if ( nivqua(iaux).eq.niveau ) then
241 etatfa = mod( hetqua(iaux) , 100 )
245 #ifdef _DEBUG_HOMARD_
246 if ( etatfa.gt.0 ) then
247 if ( laface.gt.0 ) then
254 if ( ( laface.ge.-144699 .and. laface.le.-144690 ) .or.
255 > ( laface.eq.-164226 ) ) then
256 write (ulsort,texte(langue,29)) mess14(langue,1,option),
257 > abs(laface), iaux,etatfa, decfac(laface)
262 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
269 c debut du traitement de la face courante
270 c ***************************************
272 c on ne regarde que les faces "a reactiver"
274 if ( decfac(facact).eq.-1 ) then
276 #ifdef _DEBUG_HOMARD_
277 if ( facact.gt.0 ) then
286 if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
287 > ( facact.eq.-164226 ) ) then
288 write (ulsort,texte(langue,29))
289 >'. '//mess14(langue,1,option),abs(facact),iaux,ipos,decfac(facact)
293 c 2.1.1. ==> on compte les aretes inactives a garder
295 if ( facact.gt.0 ) then
297 do 2111 , iarelo = 1 , nbare1
298 liare1(iarelo) = aretri(facact,iarelo)
303 do 2112 , iarelo = 1 , nbare1
304 liare1(iarelo) = arequa(iaux,iarelo)
307 #ifdef _DEBUG_HOMARD_
308 if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
309 > ( facact.eq.-164226 ) ) then
310 write (ulsort,90002) 'nbare1', nbare1
311 write (ulsort,90002) 'liare1', liare1
315 c nbaret = nombre d'aretes coupees en deux et a garder
316 c nbare2 = nombre d'aretes a reactiver
320 do 2113 , iarelo = 1 , nbare1
321 iarete = liare1(iarelo)
322 #ifdef _DEBUG_HOMARD_
323 if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
324 > ( facact.eq.-164226 ) ) then
325 write (ulsort,90001) '. decision arete', iarete,decare(iarete)
326 write (ulsort,90001) '. etat arete', iarete,hetare(iarete)
329 if ( decare(iarete).eq.0 ) then
330 etatar = mod( hetare(iarete) , 10 )
331 if ( etatar.eq.2 .or. etatar.eq.9 ) then
336 anodec(nbare2) = iarete
337 liare2(nbare2) = iarelo
340 #ifdef _DEBUG_HOMARD_
341 if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
342 > ( facact.eq.-164226 ) ) then
343 write (ulsort,texte(langue,22)) nbaret, nbare2
347 if ( nbaret.eq.nbare1 ) then
349 c 2.1.2. ==> toutes les aretes sont coupees en deux et a garder
350 c --------------------------------------------------
351 c on declare la face "a garder"
355 #ifdef _DEBUG_HOMARD_
356 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
359 elseif ( nbaret.eq.(nbare1-1) ) then
361 c 2.1.3. ==> toutes les aretes sauf une sont coupees en deux et a garder
362 c -----------------------------------------------------------
363 c on declare la face et la derniere arete "a garder"
366 decare(anodec(1)) = 0
368 #ifdef _DEBUG_HOMARD_
369 if ( anodec(1).eq.156780 ) then
370 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
371 write (ulsort,texte(langue,30))'decare',
372 >anodec(1),decare(anodec(1)),' (arete encore a reactiver)'
376 c on regarde toutes les faces qui s'appuient sur cette
377 c arete, on memorise celles qui sont non actives
380 ideb = posifa(anodec(1)-1)+1
381 ifin = posifa(anodec(1))
382 do 2131 , ipos = ideb , ifin
384 if ( decfac(iface).eq.-1 ) then
385 if ( iface.gt.0 ) then
386 etatfa = mod( hettri(iface) , 10 )
388 etatfa = mod( hetqua(-iface) , 100 )
390 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
391 do 2132 , ifacli = 1 , nbfali
392 if ( listfa(ifacli).eq.iface ) then
397 listfa(nbfali) = iface
403 elseif ( facact.lt.0 ) then
405 if ( nbaret.eq.nbar00 ) then
407 c 2.1.4. ==> pour un quadrangle, deux aretes sont
408 c ------------------------------------
409 c des actives a garder si on veut des boites
410 c ------------------------------------------
411 c on declare la face et les 2 dernieres aretes "a garder"
415 #ifdef _DEBUG_HOMARD_
416 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
419 do 214 , iaux = 1 , 2
421 decare(anodec(iaux)) = 0
423 #ifdef _DEBUG_HOMARD_
424 if ( anodec(iaux).eq.156780 ) then
425 write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
426 write (ulsort,texte(langue,30))'decare',
427 >anodec(iaux),decare(anodec(iaux)),' (arete encore a reactiver)'
431 c on regarde toutes les faces qui s'appuient sur cette
432 c arete, on memorise celles qui sont non actives
435 ideb = posifa(anodec(iaux)-1)+1
436 ifin = posifa(anodec(iaux))
437 do 2141 , ipos = ideb , ifin
439 if ( decfac(iface).eq.-1 ) then
440 if ( iface.gt.0 ) then
441 etatfa = mod( hettri(iface) , 10 )
443 etatfa = mod( hetqua(-iface) , 100 )
445 if ( etatfa.ge.4 .and. etatfa.le.8 ) then
446 do 2142 , ifacli = 1 , nbfali
447 if ( listfa(ifacli).eq.iface ) then
452 listfa(nbfali) = iface
462 #ifdef _DEBUG_HOMARD_
463 c 2.1.n. ==> toutes les aretes sont a reactiver : OK
465 elseif ( nbare2.eq.nbare1 ) then
467 write (ulsort,texte(langue,15))
474 if ( nbfali.gt.0 ) then
476 c on passe a la face suivante de la liste
477 c ---------------------------------------
479 #ifdef _DEBUG_HOMARD_
480 write (ulsort,texte(langue,21)) nbfali
481 write (ulsort,*) (listfa(iaux),iaux=1,nbfali)
484 facact = listfa(nbfali)
496 c 2.2. ==> regle des ecarts de niveau
497 c ==========================
499 #ifdef _DEBUG_HOMARD_
500 write (ulsort,texte(langue,13)) niveau, niveau-1
503 do 22 , laface = -nbquto , nbtrto
505 c on passe en revue les faces :
506 c . du niveau courant
511 if ( laface.gt.0 ) then
513 if ( nivtri(laface).eq.niveau ) then
514 etatfa = mod( hettri(laface) , 10 )
517 elseif ( laface.lt.0 ) then
520 if ( nivqua(iaux).eq.niveau ) then
521 etatfa = mod( hetqua(iaux) , 100 )
526 if ( etatfa.eq.0 ) then
528 #ifdef _DEBUG_HOMARD_
529 if ( laface.gt.0 ) then
531 elseif ( laface.lt.0 ) then
534 write (ulsort,texte(langue,29)) mess14(langue,1,option),
535 > abs(laface), niveau,etatfa, decfac(laface)
538 c 2.2.1. ==> liste des aretes ayant une mere
540 if ( laface.gt.0 ) then
542 do 2211 , iarelo = 1 , nbare2
543 liare2(iarelo) = aretri(laface,iarelo)
548 do 2212 , iarelo = 1 , nbare2
549 liare2(iarelo) = arequa(iaux,iarelo)
554 do 2213 , iaux = 1 , nbare2
555 if ( merare(liare2(iaux)).gt.0 ) then
557 liare1(nbare1) = liare2(iaux)
561 c 2.2.2. ==> on parcourt les aretes retenues
563 do 222 , iarelo = 1 , nbare1
565 iarete = liare1(iarelo)
566 merear = merare(iarete)
568 #ifdef _DEBUG_HOMARD_
569 write (ulsort,texte(langue,23)) iarete, decare(iarete), merear
572 c on regarde toutes les faces actives qui s'appuient
573 c sur cette arete, et on marque comme etant "a garder"
574 c celles qui sont "a reactiver"
576 ideb = posifa(merear - 1) + 1
577 ifin = posifa(merear)
578 do 2221 , ipos = ideb , ifin
581 if ( decfac(iface).eq.-1 ) then
583 if ( iface.gt.0 ) then
584 etatfa = mod( hettri(iface) , 10 )
586 etatfa = mod( hetqua(-iface) , 100 )
588 if ( etatfa.eq.0 ) then
590 #ifdef _DEBUG_HOMARD_
591 write (ulsort,texte(langue,30)) 'decfac',
592 > iface, decfac(iface), ' (face voisine)'
594 if ( iface.gt.0 ) then
595 do 2222 , jarelo = 1 , 3
596 jarete = aretri(iface,jarelo)
597 if ( decare(jarete).eq.-1 ) then
599 #ifdef _DEBUG_HOMARD_
600 write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete)
606 do 2223 , jarelo = 1 , 4
607 jarete = arequa(iaux,jarelo)
608 if ( decare(jarete).eq.-1 ) then
610 #ifdef _DEBUG_HOMARD_
611 write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete)
631 #ifdef _DEBUG_HOMARD_
633 write (ulsort,90003) 'Sortie de ',nompro
634 do 9906 , iaux = 1 , nbtrto, -1
635 write (ulsort,90001) 'decision triangle', iaux, decfac(iaux)
638 do 9905 , iaux = 1 , nbquto
639 if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then
640 write (ulsort,90001) 'decision quadrangle', iaux, decfac(-iaux)
641 write (ulsort,90002) 'aretes',
642 > arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4)
643 write (ulsort,90002) 'decare',
644 > decare(arequa(iaux,1)), decare(arequa(iaux,2)),
645 > decare(arequa(iaux,3)), decare(arequa(iaux,4))
647 if ( jaux.eq.10) then
653 do 9904 , iaux = 1 , nbarto, -1
654 write (ulsort,90001) 'decision arete', iaux,decare(iaux)
657 do 9908 , iaux = 1 , min(2,nbquto), -1
658 write (ulsort,90001) 'decfac pour quadrangle ', iaux,
660 write (ulsort,90001) 'aretes du quadrangle ', iaux,
661 >arequa(iaux,1), arequa(iaux,2),
662 >arequa(iaux,3), arequa(iaux,4)
663 write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
664 >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
665 >decare(arequa(iaux,3)), decare(arequa(iaux,4))
673 if ( codret.ne.0 ) then
677 write (ulsort,texte(langue,1)) 'Sortie', nompro
678 write (ulsort,texte(langue,2)) codret
682 #ifdef _DEBUG_HOMARD_
683 write (ulsort,texte(langue,1)) 'Sortie', nompro