1 subroutine cmh900 ( lehexa,
2 > indnoe, indare, indtet, indpyr, indhex,
4 > listso, listar, listfa, listcf,
5 > coonoe, hetnoe, arenoe,
8 > filare, merare, famare,
12 > filtet, pertet, famtet,
14 > filpyr, perpyr, fampyr,
16 > filhex, perhex, famhex,
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 - decoupage de conformite des Hexaedres
41 c ______________________________________________________________________
43 c . nom . e/s . taille . description .
44 c .____________________________________________________________________.
45 c . lehexa . e . 1 . hexaedre a decouper .
46 c . indnoe . es . 1 . indice du dernier noeud cree .
47 c . indare . es . 1 . indice de la derniere arete creee .
48 c . indtet . es . 1 . indice du dernier tetraedre cree .
49 c . indpyr . es . 1 . indice de la derniere pyramide creee .
50 c . indhex . es . 1 . indice du dernier hexaedre cree .
51 c . indptp . es . 1 . indice du dernier pere enregistre .
52 c . listso . e . 8 . numeros globaux des sommets .
53 c . listar . e . 12 . numeros globaux des aretes .
54 c . listfa . e . 6 . numeros globaux des faces .
55 c . listcf . e . 6 . codes des faces .
56 c . coonoe . es .nouvno*3. coordonnees des noeuds .
57 c . hetnoe . es . nouvno . historique de l'etat des noeuds .
58 c . arenoe . es . nouvno . arete liee a un nouveau noeud .
59 c . famnoe . es . nouvno . famille des noeuds .
60 c . hetare . es . nouvar . historique de l'etat des aretes .
61 c . somare . es .2*nouvar. numeros des extremites d'arete .
62 c . filare . es . nouvar . premiere fille des aretes .
63 c . merare . es . nouvar . mere des aretes .
64 c . famare . es . nouvar . famille des aretes .
65 c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles .
66 c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles .
67 c . filqua . e . nouvqu . premier fils des quadrangles .
68 c . hettet . es . nouvte . historique de l'etat des tetraedres .
69 c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres .
70 c . filtet . es . nouvte . premier fils des tetraedres .
71 c . pertet . es . nouvte . pere des tetraedres .
72 c . . . . si pertet(i) > 0 : numero du tetraedre .
73 c . . . . si pertet(i) < 0 : -numero dans pthepe .
74 c . famtet . es . nouvte . famille des tetraedres .
75 c . hetpyr . es . nouvpy . historique de l'etat des pyramides .
76 c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides .
77 c . filpyr . es . nouvpy . premier fils des pyramides .
78 c . perpyr . es . 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 . es . nouvpy . famille des pyramides .
82 c . hethex . es . nouvhe . historique de l'etat des hexaedres .
83 c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres .
84 c . filhex . es . nouvhe . premier fils des hexaedres .
85 c . perhex . es . nouvhe . pere des hexaedres .
86 c . famhex . es . nouvhe . famille des hexaedres .
87 c . cfahex . e . nctfhe. codes des familles des hexaedres .
88 c . . . nbfhex . 1 : famille MED .
89 c . . . . 2 : type d'hexaedres .
90 c . . . . 3 : famille des tetraedres de conformite .
91 c . . . . 4 : famille des pyramides de conformite .
92 c . ulsort . e . 1 . unite logique de la sortie generale .
93 c . langue . e . 1 . langue des messages .
94 c . . . . 1 : francais, 2 : anglais .
95 c . codret . es . 1 . code de retour des modules .
96 c ______________________________________________________________________
99 c 0. declarations et dimensionnement
102 c 0.1. ==> generalites
109 parameter ( nompro ='CMH900' )
110 parameter ( nbarin = 23 )
113 parameter ( nbsomm = 8 )
130 integer indnoe, indare, indtet, indpyr, indhex
132 integer listso(8), listar(12), listfa(6), listcf(6)
133 integer hetnoe(nouvno), arenoe(nouvno)
134 integer famnoe(nouvno)
135 integer hetare(nouvar), somare(2,nouvar)
136 integer filare(nouvar), merare(nouvar), famare(nouvar)
137 integer aretri(nouvtr,3)
138 integer arequa(nouvqu,4)
139 integer filqua(nouvqu)
140 integer hettet(nouvte), aretet(nouvta,6)
141 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
142 integer hetpyr(nouvpy), arepyr(nouvya,8)
143 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
144 integer arehex(nouvha,12)
145 integer hethex(nouvhe)
146 integer filhex(nouvhe), perhex(nouvhe)
147 integer cfahex(nctfhe,nbfhex), famhex(nouvhe)
149 double precision coonoe(nouvno,sdim)
151 integer ulsort, langue, codret
153 c 0.4. ==> variables locales
157 integer lesnoe(nbarin), areint(nbarin)
158 integer lisomm(10), liarin(10)
159 integer fdnume, fdcode
160 integer are1, are2, are3, are4
161 integer are5, are6, are7, are8
165 parameter ( nbmess = 10 )
166 character*80 texte(nblang,nbmess)
168 c 0.5. ==> initialisations
169 c ______________________________________________________________________
178 #ifdef _DEBUG_HOMARD_
179 write (ulsort,texte(langue,1)) 'Entree', nompro
183 #ifdef _DEBUG_HOMARD_
184 write (ulsort,90002) 'indnoe', indnoe
185 write (ulsort,90002) 'indtet', indtet
186 write (ulsort,90002) 'indpyr', indpyr
187 write (ulsort,90002) 'indhex', indhex
189 #ifdef _DEBUG_HOMARD_
190 write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8)
191 write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12)
192 write (ulsort,90002) 'listso', listso
193 write (ulsort,90002) 'listfa', listfa
194 write (ulsort,90002) 'listcf', listcf
201 c . des sommets de l'hexaedre
202 c . des noeuds milieux des 9 aretes coupees
203 c . des noeuds milieux des 3 faces coupees en 3 quadrangles
204 c . des noeuds milieux des 3 faces coupees en 4 quadrangles
208 lesnoe(iaux) = listso(iaux)
211 lesnoe(9) = somare(2,filare(listar(1)))
212 lesnoe(10) = somare(2,filare(listar(2)))
213 lesnoe(11) = somare(2,filare(listar(3)))
214 lesnoe(12) = somare(2,filare(listar(4)))
215 lesnoe(13) = somare(2,filare(listar(5)))
216 lesnoe(14) = somare(2,filare(listar(6)))
217 lesnoe(15) = somare(2,filare(listar(7)))
218 lesnoe(16) = somare(2,filare(listar(9)))
219 lesnoe(17) = somare(2,filare(listar(10)))
221 iaux = filqua(listfa(1))
222 lesnoe(18) = somare(2,arequa(iaux,2))
223 iaux = filqua(listfa(2))
224 lesnoe(19) = somare(2,arequa(iaux,2))
225 iaux = filqua(listfa(3))
226 lesnoe(20) = somare(2,arequa(iaux,2))
227 iaux = filqua(listfa(4))
228 lesnoe(21) = somare(2,arequa(iaux,4))
229 iaux = filqua(listfa(5))
230 lesnoe(22) = somare(2,arequa(iaux,4))
231 iaux = filqua(listfa(6))
232 lesnoe(23) = somare(2,arequa(iaux,4))
233 #ifdef _DEBUG_HOMARD_
234 do 2000 , iaux = 1 , nbarin
235 write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux)
240 c 3. Creation du noeud interne et des vingt-trois aretes internes
243 #ifdef _DEBUG_HOMARD_
244 write (ulsort,texte(langue,3)) 'CMCHPB', nompro
246 call cmchpb ( indnoe, indare, nbarin,
247 > nbsomm, lesnoe, areint,
248 > coonoe, hetnoe, arenoe,
251 > filare, merare, famare,
252 > ulsort, langue, codret )
255 c 4. Creation des vingt et une pyramides
259 jaux = cfahex(cofpfh,famhex(lehexa))
261 c 4.1. ==> Sur la face 1
263 lisomm(1) = lesnoe(2)
264 liarin(1) = areint(2)
265 lisomm(2) = lesnoe(1)
266 liarin(2) = areint(1)
267 lisomm(3) = lesnoe(4)
268 liarin(3) = areint(4)
269 lisomm(4) = lesnoe(3)
270 liarin(4) = areint(3)
271 liarin(5) = areint(9)
272 liarin(6) = areint(10)
273 liarin(7) = areint(12)
274 liarin(8) = areint(11)
275 liarin(9) = areint(18)
276 lisomm(5) = lesnoe(9)
277 lisomm(6) = lesnoe(10)
278 lisomm(7) = lesnoe(12)
279 lisomm(8) = lesnoe(11)
286 #ifdef _DEBUG_HOMARD_
287 write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro
289 call cmcpy4 ( lehexa, indpyr, indptp,
291 > lisomm, liarin, are1, are2, are3, are4,
292 > somare, filare, arequa, filqua,
294 > hetpyr, filpyr, perpyr,
296 > ulsort, langue, codret )
298 c 4.2. ==> Sur la face 2
300 lisomm(1) = lesnoe(1)
301 liarin(1) = areint(1)
302 lisomm(2) = lesnoe(2)
303 liarin(2) = areint(2)
304 lisomm(3) = lesnoe(5)
305 liarin(3) = areint(5)
306 lisomm(4) = lesnoe(6)
307 liarin(4) = areint(6)
308 liarin(5) = areint(9)
309 liarin(6) = areint(14)
310 liarin(7) = areint(16)
311 liarin(8) = areint(13)
312 liarin(9) = areint(19)
313 lisomm(5) = lesnoe(9)
314 lisomm(6) = lesnoe(14)
315 lisomm(7) = lesnoe(16)
316 lisomm(8) = lesnoe(13)
323 #ifdef _DEBUG_HOMARD_
324 write (ulsort,texte(langue,3)) 'CMCPY4 - face 2', nompro
326 call cmcpy4 ( lehexa, indpyr, indptp,
328 > lisomm, liarin, are1, are2, are3, are4,
329 > somare, filare, arequa, filqua,
331 > hetpyr, filpyr, perpyr,
333 > ulsort, langue, codret )
335 c 4.3. ==> Sur la face 3
337 lisomm(1) = lesnoe(1)
338 liarin(1) = areint(1)
339 lisomm(2) = lesnoe(6)
340 liarin(2) = areint(6)
341 lisomm(3) = lesnoe(7)
342 liarin(3) = areint(7)
343 lisomm(4) = lesnoe(4)
344 liarin(4) = areint(4)
345 liarin(5) = areint(13)
346 liarin(6) = areint(17)
347 liarin(7) = areint(15)
348 liarin(8) = areint(10)
349 liarin(9) = areint(20)
350 lisomm(5) = lesnoe(13)
351 lisomm(6) = lesnoe(17)
352 lisomm(7) = lesnoe(15)
353 lisomm(8) = lesnoe(10)
360 #ifdef _DEBUG_HOMARD_
361 write (ulsort,texte(langue,3)) 'CMCPY4 - face 3', nompro
363 call cmcpy4 ( lehexa, indpyr, indptp,
365 > lisomm, liarin, are1, are2, are3, are4,
366 > somare, filare, arequa, filqua,
368 > hetpyr, filpyr, perpyr,
370 > ulsort, langue, codret )
372 c 4.4. ==> Sur la face 4
374 liarin(1) = areint(2)
375 liarin(2) = areint(3)
376 liarin(3) = areint(8)
377 liarin(4) = areint(5)
378 liarin(5) = areint(11)
379 liarin(6) = areint(14)
380 liarin(7) = areint(21)
384 #ifdef _DEBUG_HOMARD_
385 write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro
387 call cmcpy3 ( lehexa, indpyr, indptp,
392 > hetpyr, filpyr, perpyr,
394 > ulsort, langue, codret )
396 c 4.5. ==> Sur la face 5
398 liarin(1) = areint(4)
399 liarin(2) = areint(7)
400 liarin(3) = areint(8)
401 liarin(4) = areint(3)
402 liarin(5) = areint(15)
403 liarin(6) = areint(12)
404 liarin(7) = areint(22)
408 #ifdef _DEBUG_HOMARD_
409 write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro
411 call cmcpy3 ( lehexa, indpyr, indptp,
416 > hetpyr, filpyr, perpyr,
418 > ulsort, langue, codret )
420 c 4.6. ==> Sur la face 6
422 liarin(1) = areint(6)
423 liarin(2) = areint(5)
424 liarin(3) = areint(8)
425 liarin(4) = areint(7)
426 liarin(5) = areint(16)
427 liarin(6) = areint(17)
428 liarin(7) = areint(23)
432 #ifdef _DEBUG_HOMARD_
433 write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro
435 call cmcpy3 ( lehexa, indpyr, indptp,
440 > hetpyr, filpyr, perpyr,
442 > ulsort, langue, codret )
448 if ( codret.ne.0 ) then
452 write (ulsort,texte(langue,1)) 'Sortie', nompro
453 write (ulsort,texte(langue,2)) codret
457 #ifdef _DEBUG_HOMARD_
458 write (ulsort,texte(langue,1)) 'Sortie', nompro