1 subroutine cmch33 ( 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 33
43 c Decoupage par les aretes 3 et 10
44 c ______________________________________________________________________
46 c . nom . e/s . taille . description .
47 c .____________________________________________________________________.
48 c . lehexa . e . 1 . hexaedre a decouper .
49 c . listar . e . 12 . liste des aretes de l'hexaedre a decouper .
50 c . listso . e . 8 . liste des sommets de l'hexaedre a decouper .
51 c . indnoe . es . 1 . indice du dernier noeud cree .
52 c . indare . es . 1 . indice de la derniere arete creee .
53 c . indtri . es . 1 . indice du dernier triangle cree .
54 c . indtet . es . 1 . indice du dernier tetraedre cree .
55 c . indpyr . es . 1 . indice de la derniere pyramide creee .
56 c . indptp . e . 1 . indice du dernier pere enregistre .
57 c . coonoe . es .nouvno*3. coordonnees des noeuds .
58 c . hetnoe . es . nouvno . historique de l'etat des noeuds .
59 c . arenoe . es . nouvno . arete liee a un nouveau noeud .
60 c . famnoe . es . nouvno . famille des noeuds .
61 c . hetare . es . nouvar . historique de l'etat des aretes .
62 c . somare . es .2*nouvar. numeros des extremites d'arete .
63 c . filare . es . nouvar . premiere fille des aretes .
64 c . merare . es . nouvar . mere des aretes .
65 c . famare . . nouvar . famille des aretes .
66 c . hettri . es . nouvtr . historique de l'etat des triangles .
67 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
68 c . filtri . es . nouvtr . premier fils des triangles .
69 c . pertri . es . nouvtr . pere des triangles .
70 c . famtri . es . nouvtr . famille des triangles .
71 c . nivtri . es . nouvtr . niveau des triangles .
72 c . filqua . e . nouvqu . premier fils des quadrangles .
73 c . hettet . es . nouvte . historique de l'etat des tetraedres .
74 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
75 c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres .
76 c . filtet . es . nouvte . premier fils des tetraedres .
77 c . pertet . es . nouvte . pere des tetraedres .
78 c . . . . si pertet(i) > 0 : numero du tetraedre .
79 c . . . . si pertet(i) < 0 : -numero dans pthepe .
80 c . famtet . es . nouvte . famille des tetraedres .
81 c . hetpyr . es . nouvpy . historique de l'etat des pyramides .
82 c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides .
83 c . cofapy . es .nouvyf*5. codes des faces des pyramides .
84 c . filpyr . es . nouvpy . premier fils des pyramides .
85 c . perpyr . es . nouvpy . pere des pyramides .
86 c . . . . si perpyr(i) > 0 : numero de la pyramide .
87 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
88 c . fampyr . es . nouvpy . famille des pyramides .
89 c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres .
90 c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres .
91 c . famhex . e . nouvhe . famille des hexaedres .
92 c . cfahex . . nctfhe. codes des familles des hexaedres .
93 c . . . nbfhex . 1 : famille MED .
94 c . . . . 2 : type d'hexaedres .
95 c . . . . 3 : famille des tetraedres de conformite .
96 c . . . . 4 : famille des pyramides de conformite .
97 c . ulsort . e . 1 . unite logique de la sortie generale .
98 c . langue . e . 1 . langue des messages .
99 c . . . . 1 : francais, 2 : anglais .
100 c . codret . es . 1 . code de retour des modules .
101 c . . . . 0 : pas de probleme .
102 c . . . . 1 : aucune arete ne correspond .
103 c ______________________________________________________________________
106 c 0. declarations et dimensionnement
109 c 0.1. ==> generalites
115 parameter ( nompro = 'CMCH33' )
131 integer listar(12), listso(8)
132 integer indnoe, indare, indtri, indtet, indpyr
134 integer hetnoe(nouvno), arenoe(nouvno)
135 integer famnoe(nouvno)
136 integer hetare(nouvar), somare(2,nouvar)
137 integer filare(nouvar), merare(nouvar), famare(nouvar)
138 integer hettri(nouvtr), aretri(nouvtr,3)
139 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
140 integer nivtri(nouvtr)
141 integer filqua(nouvqu)
142 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
143 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
144 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
145 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
146 integer quahex(nouvhf,6), coquhe(nouvhf,6)
147 integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
149 double precision coonoe(nouvno,sdim)
151 integer ulsort, langue, codret
153 c 0.4. ==> variables locales
156 parameter ( nbsomm = 8 )
159 integer lesnoe(10), lesare(10)
160 integer tab1(4), tab2(4)
165 integer trifad(4,0:2), cotrvo(4,0:2)
169 parameter ( nbmess = 10 )
170 character*80 texte(nblang,nbmess)
172 c 0.5. ==> initialisations
173 c ______________________________________________________________________
181 #ifdef _DEBUG_HOMARD_
182 write (ulsort,texte(langue,1)) 'Entree', nompro
189 c 2. grandeurs dependant du cas traite
201 c iaux = numero local de la 1ere arete coupee
204 c lesnoe(9) = noeud milieu de la 1ere arete coupee
205 lesnoe(9) = somare(2,filare(listar(iaux)))
207 c iaux = numero local de la 2eme arete coupee
210 c lesnoe(10) = noeud milieu de la 2eme arete coupee
211 lesnoe(10) = somare(2,filare(listar(iaux)))
213 c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour
214 c definir la ieme arete interne
215 lesnoe(1) = listso(2)
216 lesnoe(2) = listso(5)
217 lesnoe(3) = listso(6)
218 lesnoe(4) = listso(1)
219 lesnoe(5) = listso(3)
220 lesnoe(6) = listso(8)
221 lesnoe(7) = listso(7)
222 lesnoe(8) = listso(4)
223 #ifdef _DEBUG_HOMARD_
224 write(ulsort,2000) 'listso', listso
225 write(ulsort,2000) 'arete 1', listar(iaux)
226 write(ulsort,2000) 'lesnoe(9)', lesnoe(9)
227 write(ulsort,2000) 'arete 2', listar(iaux)
228 write(ulsort,2000) 'lesnoe(10)', lesnoe(10)
229 write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2)
230 write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4)
231 write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6)
232 write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8)
234 2001 format(a,i10,', ',a,i10)
237 c Triangles et aretes tracees sur les faces coupees en 3
238 c La premiere pyramide s'appuie sur celle des 2 faces de
239 c l'hexaedre qui est non decoupee et de plus petit numero
240 c local. Le positionnement de la pyramide a defini une
241 c orientation de sa face quadrangulaire.
242 c On traite les faces de l'hexaedre coupees en 3 comme suit :
243 c . la 1ere et la 2eme partagent la 1ere arete coupee
244 c . la 3eme et la 4eme partagent la 2nde arete coupee
245 c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a
246 c l'orientation de la pyramide numero 1. Idem pour 3/4.
247 c trifad(p,0) : triangle central de ce decoupage
248 c trifad(p,1) : triangle bordant la pyramide 1
249 c trifad(p,2) : triangle bordant la pyramide 2
250 c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la
251 c description du tetraedre voisin
252 c areqtr(p,1) : arete interne au quadrangle de bord et bordant le
253 c triangle trifad(p,1)
254 c areqtr(p,2) : arete interne au quadrangle de bord et bordant le
255 c triangle trifad(p,2)
257 c trifad(1,0) = triangle central de la face 1 : FF1
258 c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF1 + 1/2
259 c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF1 + 2/1
260 c areqtr(1,1) : AS1N3
261 c areqtr(1,2) : AS4N3
263 c trifad(2,0) = triangle central de la face 2 : FF4
264 c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF4 + 2/1
265 c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF4 + 1/2
266 c areqtr(2,1) : AS5N3
267 c areqtr(2,2) : AS8N3
269 c trifad(3,0) = triangle central de la face 3 : FF6
270 c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF6 + 1/2
271 c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF6 + 2/1
272 c areqtr(3,1) : AS5N10
273 c areqtr(3,2) : AS8N10
275 c trifad(4,0) = triangle central de la face 4 : FF3
276 c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF3 + 2/1
277 c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF3 + 1/2
278 c areqtr(4,1) : AS1N10
279 c areqtr(4,2) : AS4N10
286 if ( codret.eq.0 ) then
288 #ifdef _DEBUG_HOMARD_
289 write (ulsort,texte(langue,3)) 'CMCHAA', nompro
291 call cmchaa ( nulofa, lehexa,
298 > ulsort, langue, codret )
303 c 3. Creation du noeud interne et des dix aretes internes
314 c areint(10) : AN10N0
317 if ( codret.eq.0 ) then
319 #ifdef _DEBUG_HOMARD_
320 write (ulsort,texte(langue,3)) 'CMCHAB', nompro
321 write (ulsort,3001) indnoe+1
322 3001 format('.. noeud',i10)
323 write (ulsort,3002) indare+1, indare+10
324 3002 format('.. aretes de',i10,' a',i10)
327 call cmchpb ( indnoe, indare, iaux,
328 > nbsomm, lesnoe, areint,
329 > coonoe, hetnoe, arenoe,
332 > filare, merare, famare,
333 > ulsort, langue, codret )
338 c 4. Creation des triangles internes
351 c triint(13) : FS5N10
352 c triint(14) : FS1N10
355 c triint(17) : FS8N10
356 c triint(18) : FS4N10
358 c triint(20) : FS6N10
360 c triint(22) : FS7N10
363 if ( codret.eq.0 ) then
365 lesare(1) = listar(1)
366 lesare(2) = listar(6)
367 lesare(3) = listar(9)
368 lesare(4) = listar(5)
369 lesare(5) = listar(4)
370 lesare(6) = listar(8)
371 lesare(7) = listar(12)
372 lesare(8) = listar(7)
373 lesare(9) = listar(11)
374 lesare(10) = listar(2)
385 #ifdef _DEBUG_HOMARD_
386 write (ulsort,texte(langue,3)) 'CMCHAC', nompro
387 write (ulsort,4000) indtri+1, indtri+10
388 4000 format('.. triangles de',i10,' a',i10)
390 call cmchac ( indtri, triint,
391 > lesare, tab1, tab2,
392 > trifad, areint, areqtr, niveau,
393 > aretri, famtri, hettri,
394 > filtri, pertri, nivtri,
395 > ulsort, langue, codret )
400 c 5. Creation des deux pyramides
403 if ( codret.eq.0 ) then
409 #ifdef _DEBUG_HOMARD_
410 write (ulsort,texte(langue,3)) 'CMCHAD', nompro
411 write (ulsort,5000) indpyr+1, indpyr+2
412 5000 format('.. pyramides de',i10,' a',i10)
414 call cmchad ( nulofa, lehexa,
417 > hetpyr, facpyr, cofapy,
418 > filpyr, perpyr, fampyr,
421 > ulsort, langue, codret )
426 c 6. Creation des douze tetraedres dans l'ordre suivant :
441 if ( codret.eq.0 ) then
443 #ifdef _DEBUG_HOMARD_
444 write (ulsort,texte(langue,3)) 'CMCHAE', nompro
445 write (ulsort,6000) indtet+1, indtet+12
446 6000 format('.. tetraedres de',i10,' a',i10)
450 call cmchae ( lehexa, indtet, indptp, iaux,
451 > trifad, cotrvo, triint,
452 > hettet, tritet, cotrte,
453 > filtet, pertet, famtet,
455 > ulsort, langue, codret )
463 if ( codret.ne.0 ) then
467 write (ulsort,texte(langue,1)) 'Sortie', nompro
468 write (ulsort,texte(langue,2)) codret
472 #ifdef _DEBUG_HOMARD_
473 write (ulsort,texte(langue,1)) 'Sortie', nompro