1 subroutine cmch40 ( lehexa, nulofa, tabaux,
2 > somm, arext1, arext2, arext3, arext4,
3 > indare, indtri, indtet, indpyr, indptp,
5 > filare, merare, famare,
7 > filtri, pertri, famtri,
10 > hettet, tritet, cotrte,
11 > filtet, pertet, famtet,
12 > hetpyr, facpyr, cofapy,
13 > filpyr, perpyr, fampyr,
16 > trigpy, facnde, cofnde,
17 > ulsort, langue, codret )
18 c ______________________________________________________________________
22 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
24 c Version originale enregistree le 18 juin 1996 sous le numero 96036
25 c aupres des huissiers de justice Simart et Lavoir a Clamart
26 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
27 c aupres des huissiers de justice
28 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
30 c HOMARD est une marque deposee d'Electricite de France
36 c ______________________________________________________________________
38 c Creation du Maillage - Conformite - decoupage des Hexaedres
40 c - par 1 Face - etat 4x
42 c ______________________________________________________________________
44 c . nom . e/s . taille . description .
45 c .____________________________________________________________________.
46 c . lehexa . e . 1 . hexaedre a decouper .
47 c . nulofa . e . 1 . numero local de la face couppe en 4 .
48 c . tabaux . e . 4 . numeros locaux des faces coupees en 3, .
49 c . . . . dans l'ordre des pyramides p/p1+1 .
50 c . somm . e . 1 . sommets de la face non decoupee .
51 c . arexti . e . 1 . aretes de la face non decoupee .
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 . hetare . es . nouvar . historique de l'etat des aretes .
58 c . somare . es .2*nouvar. numeros des extremites d'arete .
59 c . filare . es . nouvar . premiere fille des aretes .
60 c . merare . es . nouvar . mere des aretes .
61 c . famare . . nouvar . famille des aretes .
62 c . hettri . es . nouvtr . historique de l'etat des triangles .
63 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
64 c . filtri . es . nouvtr . premier fils des triangles .
65 c . pertri . es . nouvtr . pere des triangles .
66 c . famtri . es . nouvtr . famille des triangles .
67 c . nivtri . es . nouvtr . niveau des triangles .
68 c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles .
69 c . filqua . e . nouvqu . premier fils des quadrangles .
70 c . hettet . es . nouvte . historique de l'etat des tetraedres .
71 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
72 c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres .
73 c . filtet . es . nouvte . premier fils des tetraedres .
74 c . pertet . es . nouvte . pere des tetraedres .
75 c . . . . si pertet(i) > 0 : numero du tetraedre .
76 c . . . . si pertet(i) < 0 : -numero dans pthepe .
77 c . famtet . es . nouvte . famille des tetraedres .
78 c . hetpyr . e . nouvpy . historique de l'etat des pyramides .
79 c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides .
80 c . cofapy . e .nouvyf*5. codes des faces des pyramides .
81 c . filpyr . e . nouvpy . premier fils des pyramides .
82 c . perpyr . e . nouvpy . pere des pyramides .
83 c . . . . si perpyr(i) > 0 : numero de la pyramide .
84 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
85 c . fampyr . e . nouvpy . famille des pyramides .
86 c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres .
87 c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres .
88 c . famhex . e . nouvhe . famille des hexaedres .
89 c . cfahex . . nctfhe. codes des familles des hexaedres .
90 c . . . nbfhex . 1 : famille MED .
91 c . . . . 2 : type d'hexaedres .
92 c . . . . 3 : famille des tetraedres de conformite .
93 c . . . . 4 : famille des pyramides de conformite .
94 c . trigpy . s . 4 . triangle de la grande pyramide .
95 c . ulsort . e . 1 . unite logique de la sortie generale .
96 c . langue . e . 1 . langue des messages .
97 c . . . . 1 : francais, 2 : anglais .
98 c . codret . es . 1 . code de retour des modules .
99 c . . . . 0 : pas de probleme .
100 c . . . . 1 : aucune face ne correspond .
101 c ______________________________________________________________________
104 c 0. declarations et dimensionnement
107 c 0.1. ==> generalites
113 parameter ( nompro = 'CMCH40' )
129 integer lehexa, nulofa, tabaux(4)
131 integer arext1, arext2, arext3, arext4
132 integer indare, indtri, indtet, indpyr, indptp
133 integer hetare(nouvar), somare(2,nouvar)
134 integer filare(nouvar), merare(nouvar), famare(nouvar)
135 integer hettri(nouvtr), aretri(nouvtr,3)
136 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
137 integer nivtri(nouvtr)
138 integer arequa(nouvqu,4), filqua(nouvqu)
139 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
140 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
141 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
142 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
143 integer quahex(nouvhf,6), coquhe(nouvhf,6)
144 integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
146 integer facnde, cofnde
148 integer ulsort, langue, codret
150 c 0.4. ==> variables locales
153 #ifdef _DEBUG_HOMARD_
158 integer facdec, cofdec
160 integer arefad(4), areqtr(4,2)
161 integer trifad(4,0:2), cotrvo(4,0:2)
166 parameter ( nbmess = 10 )
167 character*80 texte(nblang,nbmess)
169 c 0.5. ==> initialisations
170 c ______________________________________________________________________
178 #ifdef _DEBUG_HOMARD_
179 write (ulsort,texte(langue,1)) 'Entree', nompro
182 #ifdef _DEBUG_HOMARD_
183 1789 format(5(a,i5,', '))
192 #ifdef _DEBUG_HOMARD_
193 write (ulsort,texte(langue,3)) 'CMCHFA', nompro
195 call cmchfa ( facdec, cofdec, facnde, cofnde,
198 > trifad, cotrvo, areqtr,
200 > somare, aretri, nivtri,
204 > ulsort, langue, codret )
207 c 3. Creation des quatres aretes internes
208 c areint(p) relie le sommet somm(p) (de la pyramide fille p)
209 c au centre de la face coupee
212 if ( codret.eq.0 ) then
217 areint(iaux) = indare
219 somare(1,areint(iaux)) = min ( noefac , somm(iaux) )
220 somare(2,areint(iaux)) = max ( noefac , somm(iaux) )
222 famare(areint(iaux)) = 1
223 hetare(areint(iaux)) = 50
224 merare(areint(iaux)) = 0
225 filare(areint(iaux)) = 0
226 #ifdef _DEBUG_HOMARD_
227 3100 format('. Arete interne',i10,' de',i10,' a',i10)
228 write(ulsort,3100) indare,
229 > somare(1,areint(iaux)), somare(2,areint(iaux))
237 c 4. Creation des dix triangles internes
238 c par convention, le niveau est le meme que les quadrangles fils
242 c 4.1. ==> triangles s'appuyant sur la face decoupee
244 if ( codret.eq.0 ) then
246 #ifdef _DEBUG_HOMARD_
247 write (ulsort,texte(langue,3)) 'CMCHFB', nompro
248 cgn write (ulsort,*) '.. triangles de ', indtri + 1, ' a ', indtri+8
250 call cmchfb ( indtri, triint,
251 > hettri, aretri, nivtri,
252 > filtri, pertri, famtri,
253 > areint, arefad, areqtr, niveau,
254 > ulsort, langue, codret )
257 #ifdef _DEBUG_HOMARD_
259 write(ulsort,1789) 'TRIANGLE = ', iaux
260 write(ulsort,1789) 'arete = ', aretri(iaux,1),
261 > ' de ',somare(1,aretri(iaux,1)),
262 > ' a ',somare(2,aretri(iaux,1))
263 write(ulsort,1789) 'arete = ', aretri(iaux,2),
264 > ' de ',somare(1,aretri(iaux,2)),
265 > ' a ',somare(2,aretri(iaux,2))
266 write(ulsort,1789) 'arete = ', aretri(iaux,3),
267 > ' de ',somare(1,aretri(iaux,3)),
268 > ' a ',somare(2,aretri(iaux,3))
271 c 4.2. ==> triangles s'appuyant sur les aretes de la face non decoupee
272 c Ce sont ceux qui bordent la grande pyramide
274 if ( codret.eq.0 ) then
276 #ifdef _DEBUG_HOMARD_
277 write (ulsort,texte(langue,3)) 'CMCHFC', nompro
278 cgn write (ulsort,*) '.. triangles de ', indtri + 1, ' a ', indtri+4
280 call cmchfc ( indtri, trigpy,
281 > hettri, aretri, nivtri,
282 > filtri, pertri, famtri,
283 > areint, arext1, arext2, arext3, arext4,
285 > ulsort, langue, codret )
290 c 5. Creation des 4 pyramides dans les coins
293 iaux = cfahex(cofpfh,famhex(lehexa))
295 if ( codret.eq.0 ) then
297 #ifdef _DEBUG_HOMARD_
298 write (ulsort,texte(langue,3)) 'CMCHFD', nompro
300 call cmchfd ( indpyr,
301 > facpyr, cofapy, fampyr,
302 > hetpyr, filpyr, perpyr,
303 > trifad, cotrvo, triint, quabas, cofdec,
306 #ifdef _DEBUG_HOMARD_
307 do 5333 , iaux = indpyr-3, indpyr
308 write(ulsort,1792) iaux, (facpyr(iaux,jaux),jaux=1,5)
310 1792 format('pyramide ',i6,' : ',5i6)
316 c 6. Creation des tetraedres
319 iaux = cfahex(coftfh,famhex(lehexa))
321 if ( codret.eq.0 ) then
323 #ifdef _DEBUG_HOMARD_
324 write (ulsort,texte(langue,3)) 'CMCHFE', nompro
326 call cmchfe ( indtet, indptp,
327 > tritet, cotrte, famtet,
328 > hettet, filtet, pertet,
329 > trifad, cotrvo, triint, trigpy,
332 #ifdef _DEBUG_HOMARD_
333 do 6333 , iaux = indtet-3, indtet
334 write(ulsort,1793) iaux, (tritet(iaux,jaux),jaux=1,4)
336 1793 format('tetraedre ',i6,' : ',4i6)
345 if ( codret.ne.0 ) then
349 write (ulsort,texte(langue,1)) 'Sortie', nompro
350 write (ulsort,texte(langue,2)) codret
354 #ifdef _DEBUG_HOMARD_
355 write (ulsort,texte(langue,1)) 'Sortie', nompro