1 subroutine cmch66 ( lehexa, listar, listso,
2 > indare, indtri, indpyr,
5 > filare, merare, famare,
7 > filtri, pertri, famtri,
10 > hetpyr, facpyr, cofapy,
11 > filpyr, perpyr, fampyr,
14 > ulsort, langue, codret )
15 c ______________________________________________________________________
19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
22 c aupres des huissiers de justice Simart et Lavoir a Clamart
23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
24 c aupres des huissiers de justice
25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
27 c HOMARD est une marque deposee d'Electricite de France
33 c ______________________________________________________________________
35 c Creation du Maillage - Conformite - decoupage des Hexaedres
37 c - par 1 Arete - etat 66
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . lehexa . e . 1 . hexaedre a decouper .
44 c . listar . e . 12 . liste des aretes de l'hexaedre a decouper .
45 c . listso . e . 8 . liste des sommets de l'hexaedre a decouper .
46 c . indare . es . 1 . indice de la derniere arete creee .
47 c . indtri . es . 1 . indice du dernier triangle cree .
48 c . indpyr . es . 1 . indice de la derniere pyramide creee .
49 c . indptp . e . 1 . indice du dernier pere enregistre .
50 c . hetare . es . nouvar . historique de l'etat des aretes .
51 c . somare . es .2*nouvar. numeros des extremites d'arete .
52 c . filare . es . nouvar . premiere fille des aretes .
53 c . merare . es . nouvar . mere des aretes .
54 c . famare . . nouvar . famille des aretes .
55 c . hettri . es . nouvtr . historique de l'etat des triangles .
56 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
57 c . filtri . es . nouvtr . premier fils des triangles .
58 c . pertri . es . nouvtr . pere des triangles .
59 c . famtri . es . nouvtr . famille des triangles .
60 c . nivtri . es . nouvtr . niveau des triangles .
61 c . filqua . e . nouvqu . premier fils des quadrangles .
62 c . hetpyr . e . nouvpy . historique de l'etat des pyramides .
63 c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides .
64 c . cofapy . e .nouvyf*5. codes des faces des pyramides .
65 c . filpyr . e . nouvpy . premier fils des pyramides .
66 c . perpyr . e . nouvpy . pere des pyramides .
67 c . . . . si perpyr(i) > 0 : numero de la pyramide .
68 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
69 c . fampyr . e . nouvpy . famille des pyramides .
70 c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres .
71 c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres .
72 c . famhex . e . nouvhe . famille des hexaedres .
73 c . cfahex . . nctfhe. codes des familles des hexaedres .
74 c . . . nbfhex . 1 : famille MED .
75 c . . . . 2 : type d'hexaedres .
76 c . . . . 3 : famille des tetraedres de conformite .
77 c . . . . 4 : famille des pyramides de conformite .
78 c . ulsort . e . 1 . unite logique de la sortie generale .
79 c . langue . e . 1 . langue des messages .
80 c . . . . 1 : francais, 2 : anglais .
81 c . codret . es . 1 . code de retour des modules .
82 c . . . . 0 : pas de probleme .
83 c . . . . 1 : aucune arete ne correspond .
84 c ______________________________________________________________________
87 c 0. declarations et dimensionnement
90 c 0.1. ==> generalites
96 parameter ( nompro = 'CMCH66' )
112 integer listar(12), listso(8)
113 integer indare, indtri, indpyr
115 integer hetare(nouvar), somare(2,nouvar)
116 integer filare(nouvar), merare(nouvar), famare(nouvar)
117 integer hettri(nouvtr), aretri(nouvtr,3)
118 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
119 integer nivtri(nouvtr)
120 integer filqua(nouvqu)
121 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
122 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
123 integer quahex(nouvhf,6), coquhe(nouvhf,6)
124 integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
126 integer ulsort, langue, codret
128 c 0.4. ==> variables locales
131 integer nlarco, nuarco
132 integer noemil, somm(2)
136 integer f1, f2, f3, f4, f5, f6
137 integer cf1, cf2, cf3, cf4, cf5, cf6
138 integer trifad(2,0:2), cotrvo(2,0:2)
140 integer laface, coface
143 parameter ( nbmess = 10 )
144 character*80 texte(nblang,nbmess)
146 c 0.5. ==> initialisations
147 c ______________________________________________________________________
157 #ifdef _DEBUG_HOMARD_
158 write (ulsort,texte(langue,1)) 'Entree', nompro
162 #ifdef _DEBUG_HOMARD_
163 1789 format(5(a,i5,', '))
168 c 1.2. ==> grandeurs independantes du cas traite (phase 1)
169 c les faces de l'hexaedre et leurs codes
171 f1 = quahex(lehexa,1)
172 f2 = quahex(lehexa,2)
173 f3 = quahex(lehexa,3)
174 f4 = quahex(lehexa,4)
175 f5 = quahex(lehexa,5)
176 f6 = quahex(lehexa,6)
177 cf1 = coquhe(lehexa,1)
178 cf2 = coquhe(lehexa,2)
179 cf3 = coquhe(lehexa,3)
180 cf4 = coquhe(lehexa,4)
181 cf5 = coquhe(lehexa,5)
182 cf6 = coquhe(lehexa,6)
184 c 1.3. ==> grandeurs dependant du cas traite
185 c nlarco = numero local de l'arete coupee
188 c nuarco = numero global de l'arete coupee
189 nuarco = listar(nlarco)
191 c noemil = noeud milieu de l'arete coupee
192 noemil = somare(2,filare(nuarco))
194 c somm(1) = sommet a joindre au milieu de l'arete coupee pour
195 c definir la 1ere arete interne
197 c somm(2) = sommet a joindre au milieu de l'arete coupee pour
198 c definir la 2nde arete interne
200 #ifdef _DEBUG_HOMARD_
201 write(ulsort,2000) 'listso', listso
202 write(ulsort,2000) 'nuarco', nuarco
203 write(ulsort,2000) 'noemil', noemil
204 write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2)
206 2001 format(a,i10,', ',a,i10)
209 c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3
210 c L'arete coupee s'appuie sur deux faces de l'hexaedre.
211 c trifad(1,*) se rapporte a celle de plus petit numero local
212 c trifad(2,*) se rapporte a celle de plus grand numero local
213 c trifad(p,0) : triangle central de ce decoupage
214 c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a
215 c le plus petit numero local
216 c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a
217 c le plus petit numero local
218 c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la
219 c description de la pyramide
220 c areqtr(p,1) : arete interne au quadrangle de bord et bordant le
221 c triangle trifad(p,1)
222 c areqtr(p,2) : arete interne au quadrangle de bord et bordant le
223 c triangle trifad(p,2)
225 c trifad(1,0) = triangle central de la face 1 : FF2
226 c trifad(1,1) = triangle de la face 1 du cote de S2 : FF2 + 1/2
227 c trifad(1,2) = triangle de la face 1 du cote de S5 : FF2 + 2/1
228 c areqtr(1,1) : AS1N6
229 c areqtr(1,2) : AS6N6
232 trifad(1,0) = -filqua(laface)
233 if ( coface.lt.5 ) then
235 trifad(1,1) = trifad(1,0) + 2
237 trifad(1,2) = trifad(1,0) + 1
239 areqtr(1,1) = aretri(trifad(1,0),3)
240 areqtr(1,2) = aretri(trifad(1,0),1)
243 trifad(1,1) = trifad(1,0) + 1
245 trifad(1,2) = trifad(1,0) + 2
247 areqtr(1,1) = aretri(trifad(1,0),1)
248 areqtr(1,2) = aretri(trifad(1,0),3)
250 #ifdef _DEBUG_HOMARD_
251 write(ulsort,1789) 'laface = ', laface,', coface = ', coface
252 write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0),
253 > 'trifad(1,1) = ', trifad(1,1),
254 > 'trifad(1,2) = ', trifad(1,2)
255 write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0),
256 > 'cotrvo(1,1) = ', cotrvo(1,1),
257 > 'cotrvo(1,2) = ', cotrvo(1,2)
260 c trifad(2,0) = triangle central de la face 2 : FF4
261 c trifad(2,1) = triangle de la face 2 du cote de S2 : FF4 + 1/2
262 c trifad(2,2) = triangle de la face 2 du cote de S5 : FF4 + 2/1
263 c areqtr(2,1) : AS3N6
264 c areqtr(2,2) : AS8N6
267 trifad(2,0) = -filqua(laface)
268 if ( coface.lt.5 ) then
270 trifad(2,1) = trifad(2,0) + 1
272 trifad(2,2) = trifad(2,0) + 2
274 areqtr(2,1) = aretri(trifad(2,0),1)
275 areqtr(2,2) = aretri(trifad(2,0),3)
278 trifad(2,1) = trifad(2,0) + 2
280 trifad(2,2) = trifad(2,0) + 1
282 areqtr(2,1) = aretri(trifad(2,0),3)
283 areqtr(2,2) = aretri(trifad(2,0),1)
285 #ifdef _DEBUG_HOMARD_
286 write(ulsort,1789) 'laface = ', laface,', coface = ', coface
287 write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0),
288 > 'trifad(2,1) = ', trifad(2,1),
289 > 'trifad(2,2) = ', trifad(2,2)
290 write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0),
291 > 'cotrvo(2,1) = ', cotrvo(2,1),
292 > 'cotrvo(2,2) = ', cotrvo(2,2)
295 c 1.4. ==> grandeurs independantes du cas traite (phase 2)
297 c niveau = niveau des triangles des conformites des faces
298 niveau = nivtri(trifad(1,0))
299 #ifdef _DEBUG_HOMARD_
300 write(ulsort,1400) niveau
301 1400 format('niveau =',i3)
305 c 2. Creation des deux aretes internes
313 if ( codret.eq.0 ) then
318 areint(iaux) = indare
320 somare(1,areint(iaux)) = min ( noemil , somm(iaux) )
321 somare(2,areint(iaux)) = max ( noemil , somm(iaux) )
323 famare(areint(iaux)) = 1
324 hetare(areint(iaux)) = 50
325 merare(areint(iaux)) = 0
326 filare(areint(iaux)) = 0
333 c 3. Creation des cinq triangles internes
334 c areqtr(1,1) : AS1N6
335 c areqtr(1,2) : AS6N6
336 c areqtr(2,1) : AS3N6
337 c areqtr(2,2) : AS8N6
340 c triint(1) : le triangle contenant l'arete areqtr(1,1)
341 c triint(3) : le triangle contenant l'arete areqtr(1,2)
342 c triint(2) : le triangle contenant l'arete areqtr(2,1)
343 c triint(4) : le triangle contenant l'arete areqtr(2,2)
344 c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete
345 c coupee ; il ne touche donc pas les faces coupees
351 c par convention, le niveau est le meme que les triangles fils
357 #ifdef _DEBUG_HOMARD_
358 write (ulsort,texte(langue,3)) 'CMCTRI_66', nompro
359 write (ulsort,3000) indtri+1, indtri+5
360 3000 format('.. triangles de',i10,' a',i10)
362 triint(1) = indtri + 1
363 call cmctri ( aretri, famtri, hettri,
364 > filtri, pertri, nivtri,
365 > triint(1), listar( 2), areqtr(1,1), areint(1),
368 triint(2) = indtri + 2
369 call cmctri ( aretri, famtri, hettri,
370 > filtri, pertri, nivtri,
371 > triint(2), listar(10), areqtr(1,2), areint(2),
374 triint(3) = indtri + 3
375 call cmctri ( aretri, famtri, hettri,
376 > filtri, pertri, nivtri,
377 > triint(3), listar( 4), areqtr(2,1), areint(1),
380 triint(4) = indtri + 4
381 call cmctri ( aretri, famtri, hettri,
382 > filtri, pertri, nivtri,
383 > triint(4), listar(12), areint(2), areqtr(2,2),
386 triint(5) = indtri + 5
387 call cmctri ( aretri, famtri, hettri,
388 > filtri, pertri, nivtri,
389 > triint(5), listar( 7), areint(1), areint(2),
395 c 4. Creation des quatre pyramides
396 c Elles arrivent dans l'ordre de numerotation locale de leur
397 c quadrangle dans l'hexaedre
399 c trifad(1,1) : FF2 + 1/2
400 c trifad(1,2) : FF2 + 2/1
402 c trifad(2,1) : FF4 + 1/2
403 c trifad(2,2) : FF4 + 2/1
411 jaux = cfahex(cofpfh,famhex(lehexa))
414 #ifdef _DEBUG_HOMARD_
415 write (ulsort,texte(langue,3)) 'CMCPYR_66', nompro
416 write (ulsort,4000) indpyr+1, indpyr+4
417 4000 format('.. pyramides de',i10,' a',i10)
420 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
421 > trifad(1,1), cotrvo(1,1),
424 > trifad(2,1), cotrvo(2,1),
426 > iaux, jaux, indpyr )
429 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
431 > trifad(1,0), cotrvo(1,0),
435 > iaux, jaux, indpyr )
438 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
442 > trifad(2,0), cotrvo(2,0),
444 > iaux, jaux, indpyr )
447 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
448 > trifad(1,2), cotrvo(1,2),
449 > trifad(2,2), cotrvo(2,2),
453 > iaux, jaux, indpyr )
459 if ( codret.ne.0 ) then
463 write (ulsort,texte(langue,1)) 'Sortie', nompro
464 write (ulsort,texte(langue,2)) codret
465 write (ulsort,texte(langue,4))
469 #ifdef _DEBUG_HOMARD_
470 write (ulsort,texte(langue,1)) 'Sortie', nompro