1 subroutine cmcp36 ( lepent, 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 Pentaedres
41 c - etat 36 - par les aretes 3 et 5
43 c ______________________________________________________________________
45 c . nom . e/s . taille . description .
46 c .____________________________________________________________________.
47 c . lepent . e . 1 . pentaedre a decouper .
48 c . listar . e . 9 . liste des aretes du pentaedre a decouper .
49 c . listso . e . 6 . liste des sommets du pentaedre a decouper .
50 c . indnoe . es . 1 . indice du dernier noeud cree .
51 c . indare . es . 1 . indice de la derniere arete creee .
52 c . indtri . es . 1 . indice du dernier triangle cree .
53 c . indtet . es . 1 . indice du dernier tetraedre cree .
54 c . indpyr . es . 1 . indice de la derniere pyramide creee .
55 c . indptp . e . 1 . indice du dernier pere enregistre .
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 . . nouvar . famille des aretes .
65 c . hettri . es . nouvtr . historique de l'etat des triangles .
66 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
67 c . filtri . es . nouvtr . premier fils des triangles .
68 c . pertri . es . nouvtr . pere des triangles .
69 c . famtri . es . nouvtr . famille des triangles .
70 c . nivtri . es . nouvtr . niveau des triangles .
71 c . filqua . e . nouvqu . premier fils des quadrangles .
72 c . hettet . es . nouvte . historique de l'etat des tetraedres .
73 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
74 c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres .
75 c . filtet . es . nouvte . premier fils des tetraedres .
76 c . pertet . es . nouvte . pere des tetraedres .
77 c . . . . si pertet(i) > 0 : numero du tetraedre .
78 c . . . . si pertet(i) < 0 : -numero dans pthepe .
79 c . famtet . es . nouvte . famille des tetraedres .
80 c . hetpyr . es . nouvpy . historique de l'etat des pyramides .
81 c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides .
82 c . cofapy . es .nouvyf*5. codes des faces des pyramides .
83 c . filpyr . es . nouvpy . premier fils des pyramides .
84 c . perpyr . es . nouvpy . pere des pyramides .
85 c . . . . si perpyr(i) > 0 : numero de la pyramide .
86 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
87 c . fampyr . es . nouvpy . famille des pyramides .
88 c . facpen . e .nouvpf*5. numeros des faces des pentaedres .
89 c . cofape . e .nouvpf*5. codes des faces des pentaedres .
90 c . fampen . e . nouvpe . famille des penaedres .
91 c . cfapen . e . nctfpe*. codes des familles des pentaedres .
92 c . . . nbfpen . 1 : famille MED .
93 c . . . . 2 : type de pentaedres .
94 c . . . . 3 : famille des tetraedres de conformite .
95 c . . . . 4 : famille des pyramides de conformite .
96 c . . . . 3 : famille des tetraedres de conformite .
97 c . . . . 4 : famille des pyramides de conformite .
98 c . ulsort . e . 1 . unite logique de la sortie generale .
99 c . langue . e . 1 . langue des messages .
100 c . . . . 1 : francais, 2 : anglais .
101 c . codret . es . 1 . code de retour des modules .
102 c . . . . 0 : pas de probleme .
103 c . . . . 1 : aucune face ne correspond .
104 c ______________________________________________________________________
107 c 0. declarations et dimensionnement
110 c 0.1. ==> generalites
116 parameter ( nompro = 'CMCP36' )
134 integer listar(9), listso(6)
135 integer indnoe, indare, indtri, indtet, indpyr
137 integer hetnoe(nouvno), arenoe(nouvno)
138 integer famnoe(nouvno)
139 integer hetare(nouvar), somare(2,nouvar)
140 integer filare(nouvar), merare(nouvar), famare(nouvar)
141 integer hettri(nouvtr), aretri(nouvtr,3)
142 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
143 integer nivtri(nouvtr)
144 integer filqua(nouvqu)
145 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
146 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
147 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
148 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
149 integer facpen(nouvpf,5), cofape(nouvpf,5)
150 integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
152 double precision coonoe(nouvno,sdim)
154 integer ulsort, langue, codret
156 c 0.4. ==> variables locales
159 parameter ( nbsomm = 6 )
163 #ifdef _DEBUG_HOMARD_
169 integer lesnoe(8), lesare(7)
172 integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
178 parameter ( nbmess = 10 )
179 character*80 texte(nblang,nbmess)
181 c 0.5. ==> initialisations
182 c ______________________________________________________________________
190 #ifdef _DEBUG_HOMARD_
191 write (ulsort,texte(langue,1)) 'Entree', nompro
203 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
204 c les faces du pentaedre et leurs codes
206 f3 = facpen(lepent,3)
207 cf3 = cofape(lepent,3)
208 #ifdef _DEBUG_HOMARD_
209 f1 = facpen(lepent,1)
210 cf1 = cofape(lepent,1)
211 f2 = facpen(lepent,2)
212 cf2 = cofape(lepent,2)
213 f4 = facpen(lepent,4)
214 cf4 = cofape(lepent,4)
215 f5 = facpen(lepent,5)
216 cf5 = cofape(lepent,5)
217 write(ulsort,90002) 'f1', f1, cf1
218 write(ulsort,90002) 'f2', f2, cf2
219 write(ulsort,90002) 'f3', f3, cf3
220 write(ulsort,90002) 'f4', f4, cf4
221 write(ulsort,90002) 'f5', f5, cf5
224 c 2.2. ==> grandeurs dependant du cas traite
225 c iaux = numero local de l'arete coupee
226 c jaux = numero global de l'arete coupee
227 c noemil = noeud milieu de l'arete coupee
231 lesnoe(7) = somare(2,filare(jaux))
235 lesnoe(8) = somare(2,filare(jaux))
237 c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer
239 c Les 4 premiers sont les sommets Si de la pyramide
240 c lesnoe(5) : le dernier sommet de la face 1
241 c lesnoe(6) : le dernier sommet de la face 2
243 lesnoe(1) = listso(1)
244 lesnoe(2) = listso(3)
245 lesnoe(3) = listso(6)
246 lesnoe(4) = listso(4)
247 lesnoe(5) = listso(2)
248 lesnoe(6) = listso(5)
250 #ifdef _DEBUG_HOMARD_
251 write(ulsort,90002) 'lesnoe', lesnoe
254 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
256 c trifad(1,0) = triangle central de la face 1 : FF5
257 c trifad(1,1) = triangle de la face 1 bordant la pyr : FF5 + 1/2
258 c trifad(1,2) = triangle de la face 1 autre : FF5 + 2/1
259 c areqtr(1,1) : AS6N3
260 c areqtr(1,2) : AS5N3
262 c trifad(2,0) = triangle central de la face 2 : FF4
263 c trifad(2,1) = triangle de la face 2 bordant la pyr : FF4 + 2/1
264 c trifad(2,2) = triangle de la face 2 autre : FF4 + 1/2
265 c areqtr(2,1) : AS1N5
266 c areqtr(2,2) : AS2N5
268 c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1
269 c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0
270 c areqtr(3,0) : arete de trifad(3,0) : AS3N3
271 c areqtr(3,1) : arete de trifad(3,1) : AS2N3
272 c areqtr(3,2) : arete commune : AS1N3
274 c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1
275 c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0
276 c areqtr(4,0) : arete de trifad(4,0) : AS4N5
277 c areqtr(4,1) : arete de trifad(4,1) : AS5N5
278 c areqtr(4,2) : arete commune : AS6N5
280 if ( codret.eq.0 ) then
292 #ifdef _DEBUG_HOMARD_
293 write (ulsort,texte(langue,3)) 'CMCP3F', nompro
295 call cmcp3f ( nulofa, lepent,
300 > aretri, nivtri, filtri,
304 > trifad, cotrvo, areqtr,
305 > ulsort, langue, codret )
310 c 3. Creation du noeud interne
311 c 4. Creation des aretes internes
321 #ifdef _DEBUG_HOMARD_
322 write (ulsort,98000) indnoe+1, indnoe+1
323 write (ulsort,91000) indare+1, indare+8
326 if ( codret.eq.0 ) then
328 #ifdef _DEBUG_HOMARD_
329 write (ulsort,texte(langue,3)) 'CMCHPB', nompro
332 call cmchpb ( indnoe, indare, iaux,
333 > nbsomm, lesnoe, areint,
334 > coonoe, hetnoe, arenoe,
337 > filare, merare, famare,
338 > ulsort, langue, codret )
340 #ifdef _DEBUG_HOMARD_
341 do 400 , iaux = indare-7 , indare
342 write (ulsort,90015) 'Arete', iaux,
343 > ', sommets', somare(1,iaux),somare(2,iaux)
350 c 5. Creation des 17 triangles internes
369 #ifdef _DEBUG_HOMARD_
370 write (ulsort,92000) indtri+1, indtri+17
373 if ( codret.eq.0 ) then
375 lesare(1) = listar(1)
376 lesare(2) = listar(9)
377 lesare(3) = listar(4)
378 lesare(4) = listar(7)
379 lesare(5) = listar(2)
380 lesare(6) = listar(6)
381 lesare(7) = listar(8)
383 #ifdef _DEBUG_HOMARD_
384 write (ulsort,texte(langue,3)) 'CMCP3G', nompro
386 call cmcp3g ( indtri, triint,
388 > areint, areqtr, niveau,
389 > aretri, famtri, hettri,
390 > filtri, pertri, nivtri,
391 > ulsort, langue, codret )
393 #ifdef _DEBUG_HOMARD_
394 do 500 , iaux = indtri-16 , indtri
395 write(ulsort,90015) 'tria', iaux,
396 > ' : aretes =', (aretri(iaux,jaux),jaux=1,3)
403 c 6. Creation de la pyramide
406 #ifdef _DEBUG_HOMARD_
407 write (ulsort,95000) indpyr+1, indpyr+1
410 if ( codret.eq.0 ) then
413 jaux = cfapen(cofpfp,fampen(lepent))
415 #ifdef _DEBUG_HOMARD_
416 write (ulsort,texte(langue,3)) 'CMCPYR', nompro
419 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
425 > iaux, jaux, indpyr )
427 #ifdef _DEBUG_HOMARD_
428 do 600 , iaux = indpyr , indpyr
429 write (ulsort,90015) 'Pyra', iaux,
430 > ', faces', (facpyr(iaux,jaux),jaux=1,5)
431 write(ulsort,90015) 'Pyra', iaux,
432 > ', codes', (cofapy(iaux,jaux),jaux=1,5)
439 c 7. Creation des tetraedres
442 #ifdef _DEBUG_HOMARD_
443 write (ulsort,93000) indtet+1, indtet+10
446 if ( codret.eq.0 ) then
448 #ifdef _DEBUG_HOMARD_
449 write (ulsort,texte(langue,3)) 'CMCP3H', nompro
451 call cmcp3h ( indtet, indptp,
453 > trifad, cotrvo, triint,
454 > hettet, tritet, cotrte,
455 > filtet, pertet, famtet,
457 > ulsort, langue, codret )
459 #ifdef _DEBUG_HOMARD_
460 do 700 , iaux = indtet-9 , indtet
461 write (ulsort,90015) 'Tetra', iaux,
462 > ', faces', (tritet(iaux,jaux),jaux=1,4)
463 write(ulsort,90015) 'Tetra', iaux,
464 > ', codes', (cotrte(iaux,jaux),jaux=1,4)
474 if ( codret.ne.0 ) then
478 write (ulsort,texte(langue,1)) 'Sortie', nompro
479 write (ulsort,texte(langue,2)) codret
483 #ifdef _DEBUG_HOMARD_
484 write (ulsort,texte(langue,1)) 'Sortie', nompro