1 subroutine cmchf0 ( lehexa, etahex, etatfa,
2 > indare, indtri, indtet, indpyr,
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 > 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 Creation du Maillage - Conformite - decoupage des Hexaedres
39 c - par 1 Face - pilotage
41 c ______________________________________________________________________
43 c . nom . e/s . taille . description .
44 c .____________________________________________________________________.
45 c . lehexa . e . 1 . hexaedre a decouper .
46 c . etahex . s . 1 . etat final de l'hexaedre .
47 c . etatfa . e . 6 . etat des faces de l'hexaedre .
48 c . indare . es . 1 . indice de la derniere arete creee .
49 c . indtri . es . 1 . indice du dernier triangle cree .
50 c . indtet . es . 1 . indice du dernier tetraedre cree .
51 c . indpyr . es . 1 . indice de la derniere pyramide creee .
52 c . indptp . e . 1 . indice du dernier pere enregistre .
53 c . hetare . es . nouvar . historique de l'etat des aretes .
54 c . somare . es .2*nouvar. numeros des extremites d'arete .
55 c . filare . es . nouvar . premiere fille des aretes .
56 c . merare . es . nouvar . mere des aretes .
57 c . famare . . nouvar . famille des aretes .
58 c . hettri . es . nouvtr . historique de l'etat des triangles .
59 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
60 c . filtri . es . nouvtr . premier fils des triangles .
61 c . pertri . es . nouvtr . pere des triangles .
62 c . famtri . es . nouvtr . famille des triangles .
63 c . nivtri . es . nouvtr . niveau des triangles .
64 c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles .
65 c . filqua . e . nouvqu . premier fils des quadrangles .
66 c . hettet . es . nouvte . historique de l'etat des tetraedres .
67 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
68 c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres .
69 c . filtet . es . nouvte . premier fils des tetraedres .
70 c . pertet . es . nouvte . pere des tetraedres .
71 c . . . . si pertet(i) > 0 : numero du tetraedre .
72 c . . . . si pertet(i) < 0 : -numero dans pthepe .
73 c . famtet . es . nouvte . famille des tetraedres .
74 c . hetpyr . e . nouvpy . historique de l'etat des pyramides .
75 c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides .
76 c . cofapy . e .nouvyf*5. codes des faces des pyramides .
77 c . filpyr . e . nouvpy . premier fils des pyramides .
78 c . perpyr . e . nouvpy . pere des pyramides .
79 c . . . . si perpyr(i) > 0 : numero de la pyramide .
80 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
81 c . fampyr . e . nouvpy . famille des pyramides .
82 c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres .
83 c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres .
84 c . famhex . e . nouvhe . famille des hexaedres .
85 c . cfahex . . nctfhe. codes des familles des hexaedres .
86 c . . . nbfhex . 1 : famille MED .
87 c . . . . 2 : type d'hexaedres .
88 c . . . . 3 : famille des tetraedres de conformite .
89 c . . . . 4 : famille des pyramides de conformite .
90 c . ulsort . e . 1 . unite logique de la sortie generale .
91 c . langue . e . 1 . langue des messages .
92 c . . . . 1 : francais, 2 : anglais .
93 c . codret . es . 1 . code de retour des modules .
94 c . . . . 0 : pas de probleme .
95 c . . . . 1 : aucune face ne correspond .
96 c ______________________________________________________________________
99 c 0. declarations et dimensionnement
102 c 0.1. ==> generalites
108 parameter ( nompro = 'CMCHF0' )
123 integer lehexa, etahex, etatfa(6)
124 integer indare, indtri, indtet, indpyr
126 integer hetare(nouvar), somare(2,nouvar)
127 integer filare(nouvar), merare(nouvar), famare(nouvar)
128 integer hettri(nouvtr), aretri(nouvtr,3)
129 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
130 integer nivtri(nouvtr)
131 integer arequa(nouvqu,4), filqua(nouvqu)
132 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
133 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
134 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
135 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
136 integer quahex(nouvhf,6), coquhe(nouvhf,6)
137 integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
139 integer ulsort, langue, codret
141 c 0.4. ==> variables locales
144 integer listar(12), listso(8)
147 parameter ( nbmess = 10 )
148 character*80 texte(nblang,nbmess)
150 c 0.5. ==> initialisations
151 c ______________________________________________________________________
159 #ifdef _DEBUG_HOMARD_
160 write (ulsort,texte(langue,1)) 'Entree', nompro
162 write (ulsort,1000) 'indtri', indtri
163 write (ulsort,1000) 'indtet', indtet
164 write (ulsort,1000) 'indpyr', indpyr
165 1000 format (a6,' =',i10)
168 texte(1,4) = '(''Aucune face ne correspond.'')'
169 texte(1,5) = '(''Liste des '',a,'' :'',6i10)'
170 texte(1,6) = '(''avec les etats :'',6i10)'
172 texte(2,4) = '(''No face is good'')'
173 texte(2,5) = '(''List of '',a,'' :'',6i10)'
174 texte(2,6) = '(''with status :'',6i10)'
179 c 2. Recherche des faces, des aretes et des sommets
182 #ifdef _DEBUG_HOMARD_
183 write (ulsort,texte(langue,3)) 'UTARHE', nompro
185 call utarhe ( lehexa,
187 > arequa, quahex, coquhe,
190 #ifdef _DEBUG_HOMARD_
191 write (ulsort,texte(langue,3)) 'UTSOHE', nompro
193 call utsohe ( somare, listar, listso )
194 #ifdef _DEBUG_HOMARD_
195 write(ulsort,*) 'listar = ', listar
196 write(ulsort,*) 'listso = ', listso
202 #ifdef _DEBUG_HOMARD_
204 write(ulsort,*) 'arequa(iaux,1) = ', arequa(iaux,1),
205 > ' de ',somare(1,arequa(iaux,1)),
206 > ' a ',somare(2,arequa(iaux,1))
207 write(ulsort,*) 'arequa(iaux,2) = ', arequa(iaux,2),
208 > ' de ',somare(1,arequa(iaux,2)),
209 > ' a ',somare(2,arequa(iaux,2))
210 write(ulsort,*) 'arequa(iaux,3) = ', arequa(iaux,3),
211 > ' de ',somare(1,arequa(iaux,3)),
212 > ' a ',somare(2,arequa(iaux,3))
213 write(ulsort,*) 'arequa(iaux,4) = ', arequa(iaux,4),
214 > ' de ',somare(1,arequa(iaux,4)),
215 > ' a ',somare(2,arequa(iaux,4))
218 c 3.1. ==> C'est la face 1 qui est coupee
220 if ( etatfa(1).eq.4 ) then
222 #ifdef _DEBUG_HOMARD_
223 write (ulsort,texte(langue,3)) 'CMCH41', nompro
225 call cmch41 ( lehexa, listar, listso,
226 > indare, indtri, indtet, indpyr,
229 > filare, merare, famare,
231 > filtri, pertri, famtri,
234 > hettet, tritet, cotrte,
235 > filtet, pertet, famtet,
236 > hetpyr, facpyr, cofapy,
237 > filpyr, perpyr, fampyr,
240 > ulsort, langue, codret )
242 c 3.2. ==> C'est la face 2 qui est coupee
244 elseif ( etatfa(2).eq.4 ) then
246 #ifdef _DEBUG_HOMARD_
247 write (ulsort,texte(langue,3)) 'CMCH42', nompro
249 call cmch42 ( lehexa, listar, listso,
250 > indare, indtri, indtet, indpyr,
253 > filare, merare, famare,
255 > filtri, pertri, famtri,
258 > hettet, tritet, cotrte,
259 > filtet, pertet, famtet,
260 > hetpyr, facpyr, cofapy,
261 > filpyr, perpyr, fampyr,
264 > ulsort, langue, codret )
266 c 3.3. ==> C'est la face 3 qui est coupee
268 elseif ( etatfa(3).eq.4 ) then
270 #ifdef _DEBUG_HOMARD_
271 write (ulsort,texte(langue,3)) 'CMCH43', nompro
272 write (ulsort,*) 'indtri = ', indtri
274 call cmch43 ( lehexa, listar, listso,
275 > indare, indtri, indtet, indpyr,
278 > filare, merare, famare,
280 > filtri, pertri, famtri,
283 > hettet, tritet, cotrte,
284 > filtet, pertet, famtet,
285 > hetpyr, facpyr, cofapy,
286 > filpyr, perpyr, fampyr,
289 > ulsort, langue, codret )
291 c 3.4. ==> C'est la face 4 qui est coupee
293 elseif ( etatfa(4).eq.4 ) then
295 #ifdef _DEBUG_HOMARD_
296 write (ulsort,texte(langue,3)) 'CMCH44', nompro
298 call cmch44 ( lehexa, listar, listso,
299 > indare, indtri, indtet, indpyr,
302 > filare, merare, famare,
304 > filtri, pertri, famtri,
307 > hettet, tritet, cotrte,
308 > filtet, pertet, famtet,
309 > hetpyr, facpyr, cofapy,
310 > filpyr, perpyr, fampyr,
313 > ulsort, langue, codret )
315 c 3.5. ==> C'est la face 5 qui est coupee
317 elseif ( etatfa(5).eq.4 ) then
319 #ifdef _DEBUG_HOMARD_
320 write (ulsort,texte(langue,3)) 'CMCH45', nompro
322 call cmch45 ( lehexa, listar, listso,
323 > indare, indtri, indtet, indpyr,
326 > filare, merare, famare,
328 > filtri, pertri, famtri,
331 > hettet, tritet, cotrte,
332 > filtet, pertet, famtet,
333 > hetpyr, facpyr, cofapy,
334 > filpyr, perpyr, fampyr,
337 > ulsort, langue, codret )
339 c 3.6. ==> C'est la face 6 qui est coupee
341 elseif ( etatfa(6).eq.4 ) then
343 #ifdef _DEBUG_HOMARD_
344 write (ulsort,texte(langue,3)) 'CMCH46', nompro
346 call cmch46 ( lehexa, listar, listso,
347 > indare, indtri, indtet, indpyr,
350 > filare, merare, famare,
352 > filtri, pertri, famtri,
355 > hettet, tritet, cotrte,
356 > filtet, pertet, famtet,
357 > hetpyr, facpyr, cofapy,
358 > filpyr, perpyr, fampyr,
361 > ulsort, langue, codret )
363 c 3.7. ==> Laquelle ?
373 if ( codret.ne.0 ) then
377 write (ulsort,texte(langue,1)) 'Sortie', nompro
378 write (ulsort,texte(langue,2)) codret
379 write (ulsort,texte(langue,4))
380 write (ulsort,texte(langue,5)) mess14(langue,3,4),
381 > ( quahex(lehexa,iaux), iaux=1,6 )
382 write (ulsort,texte(langue,6)) (etatfa(iaux),iaux=1,6 )
386 #ifdef _DEBUG_HOMARD_
387 write (ulsort,texte(langue,1)) 'Sortie', nompro