1 subroutine cmcp04 ( lepent, listar, listso,
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 Pentaedres
39 c - etat 04 - par l'arete de triangle 4
41 c ______________________________________________________________________
43 c . nom . e/s . taille . description .
44 c .____________________________________________________________________.
45 c . lepent . e . 1 . pentaedre a decouper .
46 c . listar . e . 9 . liste des aretes du pentaedre a decouper .
47 c . listso . e . 6 . liste des sommets du pentaedre a decouper .
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 . filqua . e . nouvqu . premier fils des quadrangles .
65 c . hettet . es . nouvte . historique de l'etat des tetraedres .
66 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
67 c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres .
68 c . filtet . es . nouvte . premier fils des tetraedres .
69 c . pertet . es . nouvte . pere des tetraedres .
70 c . . . . si pertet(i) > 0 : numero du tetraedre .
71 c . . . . si pertet(i) < 0 : -numero dans pthepe .
72 c . famtet . es . nouvte . famille des tetraedres .
73 c . hetpyr . es . nouvpy . historique de l'etat des pyramides .
74 c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides .
75 c . cofapy . es .nouvyf*5. codes des faces des pyramides .
76 c . filpyr . es . nouvpy . premier fils des pyramides .
77 c . perpyr . es . nouvpy . pere des pyramides .
78 c . . . . si perpyr(i) > 0 : numero de la pyramide .
79 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
80 c . fampyr . es . nouvpy . famille des pyramides .
81 c . facpen . e .nouvpf*5. numeros des faces des pentaedres .
82 c . cofape . e .nouvpf*5. codes des faces des pentaedres .
83 c . fampen . e . nouvpe . famille des penaedres .
84 c . cfapen . e . nctfpe*. codes des familles des pentaedres .
85 c . . . nbfpen . 1 : famille MED .
86 c . . . . 2 : type de pentaedres .
87 c . . . . 3 : famille des tetraedres de conformite .
88 c . . . . 4 : famille des pyramides de conformite .
89 c . . . . 3 : famille des tetraedres de conformite .
90 c . . . . 4 : famille des pyramides de conformite .
91 c . ulsort . e . 1 . unite logique de la sortie generale .
92 c . langue . e . 1 . langue des messages .
93 c . . . . 1 : francais, 2 : anglais .
94 c . codret . es . 1 . code de retour des modules .
95 c . . . . 0 : pas de probleme .
96 c . . . . 1 : aucune face ne correspond .
97 c ______________________________________________________________________
100 c 0. declarations et dimensionnement
103 c 0.1. ==> generalites
109 parameter ( nompro = 'CMCP04' )
128 integer listar(9), listso(6)
129 integer indare, indtri, indtet, indpyr
131 integer hetare(nouvar), somare(2,nouvar)
132 integer filare(nouvar), merare(nouvar), famare(nouvar)
133 integer hettri(nouvtr), aretri(nouvtr,3)
134 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
135 integer nivtri(nouvtr)
136 integer filqua(nouvqu)
137 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
138 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
139 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
140 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
141 integer facpen(nouvpf,5), cofape(nouvpf,5)
142 integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
144 integer ulsort, langue, codret
146 c 0.4. ==> variables locales
149 integer nupere, nufami
153 #ifdef _DEBUG_HOMARD_
157 integer noemil, lesnoe(2), lesare(3)
160 integer laface(2), coface(2)
161 integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2)
167 parameter ( nbmess = 10 )
168 character*80 texte(nblang,nbmess)
170 c 0.5. ==> initialisations
171 c ______________________________________________________________________
179 #ifdef _DEBUG_HOMARD_
180 write (ulsort,texte(langue,1)) 'Entree', nompro
192 #ifdef _DEBUG_HOMARD_
193 write(ulsort,90002) 'listso', listso
196 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
197 c les faces du pentaedre et leurs codes
199 f1 = facpen(lepent,1)
200 cf1 = cofape(lepent,1)
201 f4 = facpen(lepent,4)
202 cf4 = cofape(lepent,4)
203 f5 = facpen(lepent,5)
204 cf5 = cofape(lepent,5)
205 #ifdef _DEBUG_HOMARD_
206 f2 = facpen(lepent,2)
207 cf2 = cofape(lepent,2)
208 f3 = facpen(lepent,3)
209 cf3 = cofape(lepent,3)
210 write(ulsort,90002) 'f1', f1, cf1
211 write(ulsort,90002) 'f2', f2, cf2
212 write(ulsort,90002) 'f3', f3, cf3
213 write(ulsort,90002) 'f4', f4, cf4
214 write(ulsort,90002) 'f5', f5, cf5
215 write (ulsort,90015) 'Triangle', f1,
216 > ', aretes', (aretri(f1,jaux),jaux=1,3)
219 c 2.2. ==> grandeurs dependant du cas traite
220 c iaux = numero local de l'arete coupee
221 c jaux = numero global de l'arete coupee
222 c noemil = noeud milieu de l'arete coupee
226 noemil = somare(2,filare(jaux))
228 c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour
229 c definir l'arete interne
230 lesnoe(1) = listso(2)
232 #ifdef _DEBUG_HOMARD_
233 write(ulsort,90002) 'noemil', noemil
234 write(ulsort,90002) 'lesnoe(1)', lesnoe(1)
237 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
238 c Sens positif : (S4,S6,S5)
240 c trifad(1,0) = triangle central de la face 1 : FF3
241 c trifad(1,1) = triangle de la face 1 du cote de S6 : FF3 + 1/2
242 c trifad(1,2) = triangle de la face 1 du cote de S4 : FF3 + 2/1
243 c areqtr(1,1) : AS3N4
244 c areqtr(1,2) : AS1N4
246 c trifad(2,0) = triangle 1 de la face 2 : FF2 + 0/1 (FF2D5)
247 c trifad(2,1) = triangle 2 de la face 2 : FF2 + 1/0 (FF2D4)
248 c areqtr(2,2) : AS5N4
250 if ( codret.eq.0 ) then
258 #ifdef _DEBUG_HOMARD_
259 write (ulsort,texte(langue,3)) 'CMCP0B', nompro
261 call cmcp0b ( nulofa, lepent,
265 > aretri, nivtri, filtri,
269 > trifad, cotrvo, areqtr,
270 > ulsort, langue, codret )
275 c 3. Creation du noeud interne
278 c 4. Creation de l'arete interne
283 #ifdef _DEBUG_HOMARD_
284 write (ulsort,91000) indare+1, indare+1
287 if ( codret.eq.0 ) then
289 #ifdef _DEBUG_HOMARD_
290 write (ulsort,texte(langue,3)) 'CMCHPA', nompro
293 call cmchpa ( indare, iaux,
294 > noemil, lesnoe, areint,
296 > filare, merare, famare,
297 > ulsort, langue, codret )
299 #ifdef _DEBUG_HOMARD_
300 write(ulsort,90006) 'areint(1) = ', areint(1),
301 > ' de ',somare(1,areint(1)),
302 > ' a ',somare(2,areint(1))
308 c 5. Creation des trois triangles internes
313 #ifdef _DEBUG_HOMARD_
314 write (ulsort,92000) indtri+1, indtri+3
317 if ( codret.eq.0 ) then
319 lesare(1) = listar(3)
320 lesare(2) = listar(8)
321 lesare(3) = listar(2)
323 #ifdef _DEBUG_HOMARD_
324 write (ulsort,texte(langue,3)) 'CMCP0C', nompro
326 call cmcp0c ( indtri, triint,
328 > areint, areqtr, niveau,
329 > aretri, famtri, hettri,
330 > filtri, pertri, nivtri,
331 > ulsort, langue, codret )
333 #ifdef _DEBUG_HOMARD_
334 do 500 , iaux = indtri-2 , indtri
335 write (ulsort,90015) 'Triangle', iaux,
336 > ', aretes', (aretri(iaux,jaux),jaux=1,3)
343 c 6. Creation des deux pyramides
346 #ifdef _DEBUG_HOMARD_
347 write (ulsort,95000) indpyr+1, indpyr+2
350 if ( codret.eq.0 ) then
353 coface(1) = per002(3,cf5)
356 coface(2) = per002(3,cf4)
358 #ifdef _DEBUG_HOMARD_
359 write (ulsort,texte(langue,3)) 'CMCP0D', nompro
361 call cmcp0d ( indpyr, indptp,
363 > trifad, cotrvo, triint,
365 > hetpyr, facpyr, cofapy,
366 > filpyr, perpyr, fampyr,
368 > ulsort, langue, codret )
370 #ifdef _DEBUG_HOMARD_
371 do 600 , iaux = indpyr-1 , indpyr
372 write (ulsort,90015) 'Pyra', iaux,
373 > ', faces', (facpyr(iaux,jaux),jaux=1,5)
374 write(ulsort,90015) 'Pyra', iaux,
375 > ', codes', (cofapy(iaux,jaux),jaux=1,5)
382 c 7. Creation du tetraedre
385 #ifdef _DEBUG_HOMARD_
386 write (ulsort,93000) indtet+1, indtet+1
389 if ( codret.eq.0 ) then
392 nufami = cfapen(coftfp,fampen(lepent))
394 coface(1) = per001(5,cf1)
396 #ifdef _DEBUG_HOMARD_
397 write (ulsort,texte(langue,3)) 'CMCTET', nompro
399 call cmctet ( tritet, cotrte, famtet,
400 > hettet, filtet, pertet,
401 > f1, trifad(1,0), triint(3), triint(1),
402 > coface(1), cotrvo(1,0), 1, 6,
403 > nupere, nufami, indtet )
405 #ifdef _DEBUG_HOMARD_
406 do 700 , iaux = indtet , indtet
407 write (ulsort,90015) 'Tetra', iaux,
408 > ', faces', (tritet(iaux,jaux),jaux=1,4)
409 write (ulsort,90015) 'Tetra', iaux,
410 > ', codes', (cotrte(iaux,jaux),jaux=1,4)
420 if ( codret.ne.0 ) then
424 write (ulsort,texte(langue,1)) 'Sortie', nompro
425 write (ulsort,texte(langue,2)) codret
429 #ifdef _DEBUG_HOMARD_
430 write (ulsort,texte(langue,1)) 'Sortie', nompro