1 subroutine dercon ( tyconf, homolo, maconf,
3 > hetare, filare, merare, arehom,
6 > filtri, pertri, nivtri, homtri,
9 > filqua, perqua, nivqua, quahom,
12 > hethex, quahex, coquhe,
13 > hetpyr, facpyr, cofapy,
14 > hetpen, facpen, cofape,
16 > ulsort, langue, codret )
17 c ______________________________________________________________________
21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
24 c aupres des huissiers de justice Simart et Lavoir a Clamart
25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
26 c aupres des huissiers de justice
27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
29 c HOMARD est une marque deposee d'Electricite de France
35 c ______________________________________________________________________
37 c traitement des DEcisions - Raffinement : CONtamination
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . tyconf . e . 1 . 0 : conforme (defaut) .
44 c . . . . 1 : non-conforme avec au minimum 2 aretes .
45 c . . . . non decoupees en 2 par face .
46 c . . . . 2 : non-conforme avec 1 seul noeud .
47 c . . . . pendant par arete .
48 c . . . . 3 : non-conforme fidele a l'indicateur .
49 c . . . . -1 : conforme, avec des boites pour les .
50 c . . . . quadrangles, hexaedres et pentaedres .
51 c . . . . -2 : non-conforme avec au maximum 1 arete .
52 c . . . . decoupee en 2 (boite pour les .
53 c . . . . quadrangles, hexaedres et pentaedres) .
54 c . homolo . e . 1 . presence d'homologue .
56 c . . . . 1 : il existe des noeuds homologues .
57 c . . . . 2 : il existe des aretes homologues .
58 c . . . . 3 : il existe des faces homologues .
59 c . maconf . e . 1 . conformite du maillage .
61 c . . . . 1 : non-conforme avec au minimum 2 aretes .
62 c . . . . non decoupees en 2 par face .
63 c . . . . 2 : non-conforme avec 1 seul noeud pendant.
65 c . . . . 3 : non-conforme fidele a l'indicateur .
66 c . . . . -1 : conforme, avec des boites pour les .
67 c . . . . quadrangles, hexaedres et pentaedres .
68 c . . . . -2 : non-conforme avec au maximum 1 arete .
69 c . . . . decoupee en 2 et des boites pour les .
70 c . . . . quadrangles, hexaedres et pentaedres .
71 c . . . . 10 : non-conforme sans autre connaissance .
72 c . decare . es . nbarto . decisions des aretes .
73 c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) .
75 c . hetare . e . nbarto . historique de l'etat des aretes .
76 c . filare . e . nbarto . premiere fille des aretes .
77 c . merare . e . nbarto . mere des aretes .
78 c . arehom . e . nbarto . ensemble des aretes homologues .
79 c . posifa . e . nbarto . pointeur sur tableau facare .
80 c . facare . e . nbfaar . liste des faces contenant une arete .
81 c . hettri . e . nbtrto . historique de l'etat des triangles .
82 c . aretri . e . nbtrto . numeros des 3 aretes des triangles .
83 c . filtri . e . nbtrto . premier fils des triangles .
84 c . pertri . e . nbtrto . pere des triangles .
85 c . nivtri . e . nbtrto . niveau des triangles .
86 c . homtri . e . nbtrto . ensemble des triangles homologues .
87 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
88 c . . . . voltri(i,k) definit le i-eme voisin de k .
89 c . . . . 0 : pas de voisin .
90 c . . . . j>0 : tetraedre j .
91 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
92 c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
93 c . . . . du triangle k tel que voltri(1/2,k) = -j .
94 c . . . . pypetr(2,j) = numero du pentaedre voisin .
95 c . . . . du triangle k tel que voltri(1/2,k) = -j .
96 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
97 c . arequa . e . nbquto . numeros des 4 aretes des quadrangles .
98 c . filqua . e . nbquto . premier fils des quadrangles .
99 c . perqua . e . nbquto . pere des quadrangles .
100 c . nivqua . e . nbquto . niveau des quadrangles .
101 c . quahom . e . nbquto . ensemble des quadrangles homologues .
102 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
103 c . . . . volqua(i,k) definit le i-eme voisin de k .
104 c . . . . 0 : pas de voisin .
105 c . . . . j>0 : hexaedre j .
106 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
107 c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
108 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
109 c . . . . pypequ(2,j) = numero du pentaedre voisin .
110 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
111 c . hettet . e . nbteto . historique de l'etat des tetraedres .
112 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
113 c . hethex . e . nbheto . historique de l'etat des hexaedres .
114 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
115 c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres .
116 c . hetpyr . e . nbpyto . historique de l'etat des pyramides .
117 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
118 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
119 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
120 c . facpen . e .nbpecf*5. numeros des faces des pentaedres .
121 c . cofape . e .nbpecf*5. code des 5 faces des pentaedres .
122 c . listfa . t . * . liste de faces a considerer .
123 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
124 c . langue . e . 1 . langue des messages .
125 c . . . . 1 : francais, 2 : anglais .
126 c . codret . es . 1 . code de retour des modules .
127 c . . . . 0 : pas de probleme .
128 c ______________________________________________________________________
131 c 0. declarations et dimensionnement
134 c 0.1. ==> generalites
140 parameter ( nompro = 'DERCON' )
159 integer tyconf, homolo, maconf
160 integer decare(0:nbarto)
161 integer decfac(-nbquto:nbtrto)
162 integer hetare(nbarto), filare(nbarto), merare(nbarto)
163 integer arehom(nbarto)
164 integer posifa(0:nbarto), facare(nbfaar)
165 integer hettri(nbtrto), aretri(nbtrto,3)
166 integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto)
167 integer homtri(nbtrto)
168 integer voltri(2,nbtrto), pypetr(2,*)
169 integer hetqua(nbquto), arequa(nbquto,4)
170 integer filqua(nbquto), perqua(nbquto), nivqua(nbquto)
171 integer quahom(nbquto)
172 integer volqua(2,nbquto), pypequ(2,*)
173 integer hettet(nbteto), tritet(nbtecf,4)
174 integer hethex(nbheto), quahex(nbhecf,6), coquhe(nbhecf,6)
175 integer hetpyr(nbpyto), facpyr(nbpycf,5), cofapy(nbpycf,5)
176 integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5)
179 integer ulsort, langue, codret
181 c 0.4. ==> variables locales
183 integer nivdeb, nivfin
186 #ifdef _DEBUG_HOMARD_
191 parameter ( nbmess = 30 )
192 character*80 texte(nblang,nbmess)
194 c 0.5. ==> initialisations
195 c ______________________________________________________________________
203 #ifdef _DEBUG_HOMARD_
204 write (ulsort,texte(langue,1)) 'Entree', nompro
212 #ifdef _DEBUG_HOMARD_
213 write (ulsort,90002) 'maconf', maconf
214 write (ulsort,90002) 'tyconf', tyconf
217 #ifdef _DEBUG_HOMARD_
218 do 1103 , iaux = 1 , nbarto
219 if ( iaux.eq.-17735 .or. iaux.eq.-1207 ) then
220 write (ulsort,90001) '.. arete e/d', iaux,
221 > hetare(iaux), decare(iaux)
225 #ifdef _DEBUG_HOMARD_
226 do 1104 , iaux = 1 , nbtrto
227 if ( iaux.eq.-830 .or. iaux.eq.-800) then
228 write (ulsort,90001) '.triangle', iaux,
229 > aretri(iaux,1), aretri(iaux,2),
231 write (ulsort,90002) 'niveau et decision',
232 > nivtri(iaux), decfac(iaux)
234 write (ulsort,90001) 'arete e/d', aretri(iaux,jaux),
235 > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux))
239 do 1105 , iaux = 1 , nbquto
240 if ( iaux.eq.-2311 ) then
241 cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or.
242 cgn > iaux.eq.333 .or. iaux.eq.1662.or.
243 cgn > iaux.eq.1658 .or. iaux.eq.1666 .or.
244 cgn > iaux.eq.729 .or. iaux.eq.721 ) then
245 write (ulsort,90001) 'quadrangle', iaux,
246 > arequa(iaux,1), arequa(iaux,2),
247 > arequa(iaux,3), arequa(iaux,4)
248 write (ulsort,90002) 'niveau et decision',
249 > nivqua(iaux), decfac(-iaux)
251 write (ulsort,90001) 'arete e/d', arequa(iaux,jaux),
252 > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux))
257 cgn print *,'entree de',nompro,'perqua : ',perqua
260 c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant
262 c tyconf = 1 : non-conforme avec au minimum 2 aretes non decoupees
270 c ------X------ --------X------
272 c -------X------- ---------------
279 c --------X------ --------X------
281 c Cela correspond au raffinement libre, sans appliquer le raffinement
282 c de conformite final
284 c tyconf = 2 : non-conforme avec 1 noeud pendant unique par arete
292 c ------X------ --------X------
301 c ------X------ --------X------
303 c -------X------- -------X-------
310 c --------X------ --------X------
311 c Cela correspond a ignorer la regle des deux voisins, mais a
312 c appliquer la regle sur les differences de niveau
316 nivfin = max(nivinf-1,0)
317 do 20 , niveau = nivdeb , nivfin , -1
319 #ifdef _DEBUG_HOMARD_
321 write (ulsort,texte(langue,12)) niveau
326 c 2.1. ==> cas sans entites homologues, sauf eventuellement des noeuds
328 if ( homolo.le.1 ) then
330 c 2.1.1. ==> regle des ecarts de niveau
331 c ==========================
333 if ( codret.eq.0 ) then
335 #ifdef _DEBUG_HOMARD_
336 write (ulsort,texte(langue,3)) 'DERCO2', nompro
339 call derco2 ( tyconf, iaux,
342 > hettri, aretri, filtri, nivtri,
344 > hetqua, arequa, filqua, nivqua,
350 > ulsort, langue, codret )
354 c 2.1.2. ==> regle des deux voisins
355 c ======================
356 c elle s'applique aux cas d'adaptation :
357 c tyconf = 0 ; conforme
358 c tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees
359 c tyconf = -1 ; conforme avec boites
360 c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee
362 if ( codret.eq.0 ) then
364 if ( tyconf.le.1 ) then
366 #ifdef _DEBUG_HOMARD_
367 write (ulsort,texte(langue,3)) 'DERCO1', nompro
370 call derco1 ( tyconf,
375 > hettri, aretri, nivtri,
376 > hetqua, arequa, nivqua,
378 > ulsort, langue, codret )
379 #ifdef _DEBUG_HOMARD_
380 do 2123 , iaux = 1 , nbarto
381 if ( iaux.eq.-4739 .or. iaux.eq.-1207 ) then
382 write (ulsort,90001) '.. arete e/d', iaux,
383 > hetare(iaux), decare(iaux)
386 do 2125 , jaux = 1 , nbquto
387 if ( jaux.eq.-215996 .or. jaux.eq.-66980 ) then
388 write (ulsort,90001) 'quadrangle', jaux,
389 > arequa(jaux,1), arequa(jaux,2),
390 > arequa(jaux,3), arequa(jaux,4)
391 write (ulsort,90002) 'de decision', decfac(-jaux)
400 c 2.1.3. ==> ecarts de niveau, complements non conforme, 1 noeud pendant
401 c ===========================================================
403 if ( tyconf.eq.2 ) then
405 if ( niveau.gt.1 ) then
407 if ( codret.eq.0 ) then
409 #ifdef _DEBUG_HOMARD_
410 write (ulsort,texte(langue,3)) 'DERCO3', nompro
417 > hettri, aretri, pertri, nivtri,
419 > hetqua, arequa, perqua, nivqua,
421 > ulsort, langue, codret )
422 #ifdef _DEBUG_HOMARD_
423 do 2135 , jaux = 1 , nbquto
424 if ( jaux.eq.-94774 ) then
425 write (ulsort,90001) 'quadrangle', jaux,
426 > arequa(jaux,1), arequa(jaux,2),
427 > arequa(jaux,3), arequa(jaux,4)
428 write (ulsort,90002) 'de decision', decfac(-jaux)
437 c=======================================================================
438 if ( nbteto.gt.0 .or. nbheto.gt.0 .or. nbpeto.gt.0 ) then
440 if ( codret.eq.0 ) then
442 c ATTENTION : c'est une verrue pour imposer un rapport 1/4 sur
443 c les recollements de non conformite
444 c a filtrer quand on aura ameliore le pilotage
446 #ifdef _DEBUG_HOMARD_
447 write (ulsort,texte(langue,3)) 'DERCO8', nompro
453 > hettri, aretri, pertri, nivtri,
455 > hetqua, arequa, perqua, nivqua,
459 > ulsort, langue, codret )
460 #ifdef _DEBUG_HOMARD_
461 do 21351 , jaux = 1 , nbquto
462 if ( jaux.eq.-94774 ) then
463 write (ulsort,90001) 'quadrangle', jaux,
464 > arequa(jaux,1), arequa(jaux,2),
465 > arequa(jaux,3), arequa(jaux,4)
466 write (ulsort,90002) 'de decision', decfac(-jaux)
474 c=======================================================================
476 if ( codret.eq.0 ) then
478 #ifdef _DEBUG_HOMARD_
479 write (ulsort,texte(langue,3)) 'DERCO7', nompro
485 > hettri, aretri, nivtri,
487 > hetqua, arequa, nivqua,
489 > ulsort, langue, codret )
491 #ifdef _DEBUG_HOMARD_
492 do 21353 , iaux = 1 , nbarto
493 if ( iaux.eq.-4739 .or. iaux.eq.-1207 ) then
494 write (ulsort,90001) '.. arete e/d', iaux,
495 > hetare(iaux), decare(iaux)
498 do 21352 , jaux = 1 , nbquto
499 if ( jaux.eq.-94774 ) then
500 write (ulsort,90001) 'quadrangle', jaux,
501 > arequa(jaux,1), arequa(jaux,2),
502 > arequa(jaux,3), arequa(jaux,4)
503 write (ulsort,90002) 'de decision', decfac(-jaux)
511 c 2.2. ==> cas avec homologues
515 c 2.2.1. ==> regle des ecarts de niveau
516 c ==========================
518 if ( codret.eq.0 ) then
520 c if ( niveau.gt.0 ) then
522 #ifdef _DEBUG_HOMARD_
523 write (ulsort,texte(langue,3)) 'DERCO5', nompro
526 call derco5 ( tyconf, iaux,
528 > hetare, filare, arehom,
529 > hettri, aretri, filtri, nivtri, homtri,
531 > hetqua, arequa, filqua, nivqua, quahom,
537 > ulsort, langue, codret )
543 c 2.2.2. ==> regle des deux voisins
544 c ======================
545 c elle s'applique aux cas de raffinement :
547 c tyconf = 1 ; non-conforme avec au miximum 2 aretes non coupees
548 c tyconf = -1 ; libre avec boites
549 c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee
551 if ( codret.eq.0 ) then
553 if ( tyconf.le.1 ) then
555 #ifdef _DEBUG_HOMARD_
556 write (ulsort,texte(langue,3)) 'DERCO4', nompro
559 call derco4 ( tyconf,
564 > hettri, aretri, nivtri,
565 > hetqua, arequa, nivqua,
567 > ulsort, langue, codret )
573 c 2.2.3. ==> ecarts de niveau, complements non conforme, 1 noeud pendant
574 c ===========================================================
576 if ( tyconf.eq.2 ) then
578 if ( niveau.gt.1 ) then
580 if ( codret.eq.0 ) then
582 #ifdef _DEBUG_HOMARD_
583 write (ulsort,texte(langue,3)) 'DERCO6', nompro
590 > hettri, aretri, pertri, nivtri,
592 > hetqua, arequa, perqua, nivqua,
595 > ulsort, langue, codret )
601 if ( codret.eq.0 ) then
603 #ifdef _DEBUG_HOMARD_
604 write (ulsort,texte(langue,3)) 'DERCO7', nompro
610 > hettri, aretri, nivtri,
612 > hetqua, arequa, nivqua,
614 > ulsort, langue, codret )
621 cgn print *,'fin 20, n = ',niveau,', ',decfac(5), decfac(8)
625 #ifdef _DEBUG_HOMARD_
626 write (ulsort,texte(langue,1)) 'Sortie', nompro
627 do 2103 , iaux = 1 , nbarto
628 if ( iaux.eq.-17735 .or. iaux.eq.-1207 ) then
629 write (ulsort,90001) '.. arete e/d', iaux,
630 > hetare(iaux), decare(iaux)
633 do 2104 , iaux = 1 , nbtrto
634 if ( iaux.eq.-830 .or. iaux.eq.-833 .or. iaux.eq.-800) then
635 write (ulsort,90001) '.triangle', iaux,
636 > aretri(iaux,1), aretri(iaux,2),
638 write (ulsort,90002) '.. niveau et decision',
639 > nivtri(iaux), decfac(iaux)
641 write (ulsort,90001) '.. arete e/d', aretri(iaux,jaux),
642 > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux))
646 do 2105 , iaux = 1 , nbquto
647 if ( iaux.eq.-2311 ) then
648 cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or.
649 cgn > iaux.eq.333 .or. iaux.eq.1662 .or.
650 cgn > iaux.eq.1658 .or. iaux.eq.1666 .or.
651 cgn > iaux.eq.729 .or. iaux.eq.721 ) then
652 write (ulsort,90001) 'quadrangle', iaux,
653 > arequa(iaux,1), arequa(iaux,2),
654 > arequa(iaux,3), arequa(iaux,4)
655 write (ulsort,90002) 'de decision', decfac(-iaux)
657 write (ulsort,90001) 'arete e/d', arequa(iaux,jaux),
658 > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux))
668 if ( codret.ne.0 ) then
672 write (ulsort,texte(langue,1)) 'Sortie', nompro
673 write (ulsort,texte(langue,2)) codret
677 #ifdef _DEBUG_HOMARD_
678 write (ulsort,texte(langue,1)) 'Sortie', nompro