1 subroutine cmch14 ( lehexa, listar, listso,
2 > indnoe, indare, indtri, indtet, indpyr,
4 > coonoe, hetnoe, arenoe,
7 > filare, merare, famare,
9 > filtri, pertri, famtri,
12 > hettet, tritet, cotrte,
13 > filtet, pertet, famtet,
14 > hetpyr, facpyr, cofapy,
15 > filpyr, perpyr, fampyr,
18 > ulsort, langue, codret )
19 c ______________________________________________________________________
23 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
25 c Version originale enregistree le 18 juin 1996 sous le numero 96036
26 c aupres des huissiers de justice Simart et Lavoir a Clamart
27 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
28 c aupres des huissiers de justice
29 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
31 c HOMARD est une marque deposee d'Electricite de France
37 c ______________________________________________________________________
39 c Creation du Maillage - Conformite - decoupage des Hexaedres
41 c - par 2 Aretes - etat 14
43 c Decoupage par les aretes 4 et 6
45 c ______________________________________________________________________
47 c . nom . e/s . taille . description .
48 c .____________________________________________________________________.
49 c . lehexa . e . 1 . hexaedre a decouper .
50 c . listar . e . 12 . liste des aretes de l'hexaedre a decouper .
51 c . listso . e . 8 . liste des sommets de l'hexaedre a decouper .
52 c . indnoe . es . 1 . indice du dernier noeud cree .
53 c . indare . es . 1 . indice de la derniere arete creee .
54 c . indtri . es . 1 . indice du dernier triangle cree .
55 c . indtet . es . 1 . indice du dernier tetraedre cree .
56 c . indpyr . es . 1 . indice de la derniere pyramide creee .
57 c . indptp . e . 1 . indice du dernier pere enregistre .
58 c . coonoe . es .nouvno*3. coordonnees des noeuds .
59 c . hetnoe . es . nouvno . historique de l'etat des noeuds .
60 c . arenoe . es . nouvno . arete liee a un nouveau noeud .
61 c . famnoe . es . nouvno . famille des noeuds .
62 c . hetare . es . nouvar . historique de l'etat des aretes .
63 c . somare . es .2*nouvar. numeros des extremites d'arete .
64 c . filare . es . nouvar . premiere fille des aretes .
65 c . merare . es . nouvar . mere des aretes .
66 c . famare . . nouvar . famille des aretes .
67 c . hettri . es . nouvtr . historique de l'etat des triangles .
68 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
69 c . filtri . es . nouvtr . premier fils des triangles .
70 c . pertri . es . nouvtr . pere des triangles .
71 c . famtri . es . nouvtr . famille des triangles .
72 c . nivtri . es . nouvtr . niveau des triangles .
73 c . filqua . e . nouvqu . premier fils des quadrangles .
74 c . hettet . es . nouvte . historique de l'etat des tetraedres .
75 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
76 c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres .
77 c . filtet . es . nouvte . premier fils des tetraedres .
78 c . pertet . es . nouvte . pere des tetraedres .
79 c . . . . si pertet(i) > 0 : numero du tetraedre .
80 c . . . . si pertet(i) < 0 : -numero dans pthepe .
81 c . famtet . es . nouvte . famille des tetraedres .
82 c . hetpyr . es . nouvpy . historique de l'etat des pyramides .
83 c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides .
84 c . cofapy . es .nouvyf*5. codes des faces des pyramides .
85 c . filpyr . es . nouvpy . premier fils des pyramides .
86 c . perpyr . es . nouvpy . pere des pyramides .
87 c . . . . si perpyr(i) > 0 : numero de la pyramide .
88 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
89 c . fampyr . es . nouvpy . famille des pyramides .
90 c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres .
91 c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres .
92 c . famhex . e . nouvhe . famille des hexaedres .
93 c . cfahex . . nctfhe. codes des familles des hexaedres .
94 c . . . nbfhex . 1 : famille MED .
95 c . . . . 2 : type d'hexaedres .
96 c . . . . 3 : famille des tetraedres de conformite .
97 c . . . . 4 : famille des pyramides de conformite .
98 c . ulsort . e . 1 . unite logique de la sortie generale .
99 c . langue . e . 1 . langue des messages .
100 c . . . . 1 : francais, 2 : anglais .
101 c . codret . es . 1 . code de retour des modules .
102 c . . . . 0 : pas de probleme .
103 c . . . . 1 : aucune arete ne correspond .
104 c ______________________________________________________________________
107 c 0. declarations et dimensionnement
110 c 0.1. ==> generalites
116 parameter ( nompro = 'CMCH14' )
133 integer listar(12), listso(8)
134 integer indnoe, indare, indtri, indtet, indpyr
136 integer hetnoe(nouvno), arenoe(nouvno)
137 integer famnoe(nouvno)
138 integer hetare(nouvar), somare(2,nouvar)
139 integer filare(nouvar), merare(nouvar), famare(nouvar)
140 integer hettri(nouvtr), aretri(nouvtr,3)
141 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
142 integer nivtri(nouvtr)
143 integer filqua(nouvqu)
144 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
145 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
146 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
147 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
148 integer quahex(nouvhf,6), coquhe(nouvhf,6)
149 integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
151 double precision coonoe(nouvno,sdim)
153 integer ulsort, langue, codret
155 c 0.4. ==> variables locales
158 parameter ( nbsomm = 8 )
161 integer laface, codfac
162 integer lesnoe(10), lesare(10)
168 integer trifad(4,0:2), cotrvo(4,0:2)
172 parameter ( nbmess = 10 )
173 character*80 texte(nblang,nbmess)
175 c 0.5. ==> initialisations
176 c ______________________________________________________________________
184 #ifdef _DEBUG_HOMARD_
185 write (ulsort,texte(langue,1)) 'Entree', nompro
192 c 2. grandeurs dependant du cas traite
204 c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour
205 c definir la ieme arete interne
206 lesnoe(1) = listso(6)
207 lesnoe(2) = listso(7)
208 lesnoe(3) = listso(4)
209 lesnoe(4) = listso(1)
210 lesnoe(5) = listso(5)
211 lesnoe(6) = listso(8)
212 lesnoe(7) = listso(3)
213 lesnoe(8) = listso(2)
215 c iaux = numero local de la 1ere arete coupee : celle qui partage un
216 c sommet avec la 1ere pyramide
219 c lesnoe(9) = noeud milieu de la 1ere arete coupee
220 lesnoe(9) = somare(2,filare(listar(iaux)))
222 c iaux = numero local de la 2eme arete coupee : celle qui partage un
223 c sommet avec la 2nde pyramide
226 c lesnoe(10) = noeud milieu de la 2eme arete coupee
227 lesnoe(10) = somare(2,filare(listar(iaux)))
229 #ifdef _DEBUG_HOMARD_
230 write(ulsort,*) 'listso = ', listso
231 write(ulsort,*) 'arete 1 = ', listar(4)
232 write(ulsort,*) 'lesnoe(9) = ', lesnoe(9)
233 write(ulsort,*) 'arete 2 = ', listar(6)
234 write(ulsort,*) 'lesnoe(10) = ', lesnoe(10)
235 write(ulsort,*) 'lesnoe(1) = ', lesnoe(1),
236 > ', lesnoe(2) = ', lesnoe(2)
237 write(ulsort,*) 'lesnoe(3) = ', lesnoe(3),
238 > ', lesnoe(4) = ', lesnoe(4)
239 write(ulsort,*) 'lesnoe(5) = ', lesnoe(5),
240 > ', lesnoe(6) = ', lesnoe(6)
241 write(ulsort,*) 'lesnoe(7) = ', lesnoe(7),
242 > ', lesnoe(8) = ', lesnoe(8)
245 c Triangles et aretes tracees sur les faces coupees en 3
246 c La premiere pyramide s'appuie sur celle des 2 faces de
247 c l'hexaedre qui est non decoupee et de plus petit numero
248 c local. Le positionnement de la pyramide a defini une
249 c orientation de sa face quadrangulaire.
250 c On traite les faces de l'hexaedre coupees en 3 comme suit :
251 c . la 1ere et la 2eme partagent la 1ere arete coupee
252 c . la 3eme et la 4eme partagent la 2nde arete coupee
253 c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a
254 c l'orientation de la pyramide numero 1.
255 c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a
256 c l'orientation de la pyramide numero 2.
257 c trifad(p,0) : triangle central de ce decoupage
258 c trifad(p,1) : triangle ayant une arete commune a une pyramide
259 c trifad(p,2) : triangle sans arete commune avec une pyramide
260 c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la
261 c description du tetraedre voisin
262 c areqtr(p,1) : arete interne au quadrangle de bord et bordant le
263 c triangle trifad(p,1)
264 c areqtr(p,2) : arete interne au quadrangle de bord et bordant le
265 c triangle trifad(p,2)
267 c trifad(1,0) = triangle central de la face 1 : FF5
268 c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF5 + 1/2
269 c trifad(1,2) = triangle de la face 1 de l'autre cote : FF5 + 2/1
270 c areqtr(1,1) : AS7N4
271 c areqtr(1,2) : AS8N4
273 c trifad(2,0) = triangle central de la face 2 : FF1
274 c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1
275 c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2
276 c areqtr(2,1) : AS1N4
277 c areqtr(2,2) : AS2N4
279 c trifad(3,0) = triangle central de la face 3 : FF2
280 c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF2 + 1/2
281 c trifad(3,2) = triangle de la face 3 de l'autre cote : FF2 + 2/1
282 c areqtr(3,1) : AS6N6
283 c areqtr(3,2) : AS1N6
285 c trifad(4,0) = triangle central de la face 4 : FF4
286 c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF4 + 2/1
287 c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2
288 c areqtr(4,1) : AS8N6
289 c areqtr(4,2) : AS3N6
296 if ( codret.eq.0 ) then
298 #ifdef _DEBUG_HOMARD_
299 write (ulsort,texte(langue,3)) 'CMCHAA', nompro
301 call cmchaa ( nulofa, lehexa,
308 > ulsort, langue, codret )
313 c 3. Creation du noeud interne et des dix aretes internes
327 if ( codret.eq.0 ) then
329 #ifdef _DEBUG_HOMARD_
330 write (ulsort,texte(langue,3)) 'CMCHAB', nompro
331 write (ulsort,*) '.. noeud ', indnoe+1
332 write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10
335 call cmchpb ( indnoe, indare, iaux,
336 > nbsomm, lesnoe, areint,
337 > coonoe, hetnoe, arenoe,
340 > filare, merare, famare,
341 > ulsort, langue, codret )
346 c 4. Creation des triangles internes
354 c triint( 8) : FA3 (F2/F4)
355 c triint( 9) : FA8 (F1/F4)
356 c triint(10) : FA1 (F2/F3)
371 if ( codret.eq.0 ) then
373 lesare( 1) = listar(10)
374 lesare( 2) = listar(7)
375 lesare( 3) = listar(2)
376 lesare( 4) = listar(5)
377 lesare( 5) = listar(9)
378 lesare( 6) = listar(11)
379 lesare( 7) = listar(12)
380 lesare( 8) = listar(3)
381 lesare( 9) = -listar(8)
382 lesare(10) = listar(1)
387 #ifdef _DEBUG_HOMARD_
388 write (ulsort,texte(langue,3)) 'CMCHAH', nompro
389 write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10
391 call cmchah ( indtri, triint,
393 > trifad, areint, areqtr, niveau,
394 > aretri, famtri, hettri,
395 > filtri, pertri, nivtri,
396 > ulsort, langue, codret )
401 c 5. Creation des deux pyramides
404 if ( codret.eq.0 ) then
407 jaux = cfahex(cofpfh,famhex(lehexa))
409 #ifdef _DEBUG_HOMARD_
410 write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2
413 laface = quahex(lehexa,3)
414 codfac = coquhe(lehexa,3)
416 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
422 > iaux, jaux, indpyr )
424 laface = quahex(lehexa,6)
425 codfac = coquhe(lehexa,6)
427 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
433 > iaux, jaux, indpyr )
435 #ifdef _DEBUG_HOMARD_
436 do 4333 , iaux = indpyr-1, indpyr
437 write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5)
439 1789 format('pyramide ',i6,' : ',5i6)
445 c 6. Creation des douze tetraedres dans l'ordre suivant :
460 if ( codret.eq.0 ) then
462 #ifdef _DEBUG_HOMARD_
463 write (ulsort,texte(langue,3)) 'CMCHAI', nompro
464 write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12
468 call cmchai ( lehexa, indtet, indptp, iaux,
469 > trifad, cotrvo, triint,
470 > hettet, tritet, cotrte,
471 > filtet, pertet, famtet,
473 > ulsort, langue, codret )
481 if ( codret.ne.0 ) then
485 write (ulsort,texte(langue,1)) 'Sortie', nompro
486 write (ulsort,texte(langue,2)) codret
490 #ifdef _DEBUG_HOMARD_
491 write (ulsort,texte(langue,1)) 'Sortie', nompro