1 subroutine cmcp22 ( lepent, listar,
2 > indare, indtri, indtet,
5 > filare, merare, famare,
7 > filtri, pertri, famtri,
10 > hettet, tritet, cotrte,
11 > filtet, pertet, famtet,
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 Pentaedres
37 c - etat 22 - par les aretes 2 et 9
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . lepent . e . 1 . pentaedre a decouper .
44 c . listar . e . 9 . liste des aretes du pentaedre a decouper .
45 c . indare . es . 1 . indice de la derniere arete creee .
46 c . indtri . es . 1 . indice du dernier triangle cree .
47 c . indtet . es . 1 . indice du dernier tetraedre cree .
48 c . indptp . e . 1 . indice du dernier pere enregistre .
49 c . hetare . es . nouvar . historique de l'etat des aretes .
50 c . somare . es .2*nouvar. numeros des extremites d'arete .
51 c . filare . es . nouvar . premiere fille des aretes .
52 c . merare . es . nouvar . mere des aretes .
53 c . famare . . nouvar . famille des aretes .
54 c . hettri . es . nouvtr . historique de l'etat des triangles .
55 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
56 c . filtri . es . nouvtr . premier fils des triangles .
57 c . pertri . es . nouvtr . pere des triangles .
58 c . famtri . es . nouvtr . famille des triangles .
59 c . nivtri . es . nouvtr . niveau des triangles .
60 c . filqua . e . nouvqu . premier fils des quadrangles .
61 c . hettet . es . nouvte . historique de l'etat des tetraedres .
62 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
63 c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres .
64 c . filtet . es . nouvte . premier fils des tetraedres .
65 c . pertet . es . nouvte . pere des tetraedres .
66 c . . . . si pertet(i) > 0 : numero du tetraedre .
67 c . . . . si pertet(i) < 0 : -numero dans pthepe .
68 c . famtet . es . nouvte . famille des tetraedres .
69 c . facpen . e .nouvpf*5. numeros des faces des pentaedres .
70 c . cofape . e .nouvpf*5. codes des faces des pentaedres .
71 c . fampen . e . nouvpe . famille des penaedres .
72 c . cfapen . e . nctfpe*. codes des familles des pentaedres .
73 c . . . nbfpen . 1 : famille MED .
74 c . . . . 2 : type de pentaedres .
75 c . . . . 3 : famille des tetraedres de conformite .
76 c . . . . 4 : famille des pyramides de conformite .
77 c . . . . 3 : famille des tetraedres de conformite .
78 c . . . . 4 : famille des pyramides de conformite .
79 c . ulsort . e . 1 . unite logique de la sortie generale .
80 c . langue . e . 1 . langue des messages .
81 c . . . . 1 : francais, 2 : anglais .
82 c . codret . es . 1 . code de retour des modules .
83 c . . . . 0 : pas de probleme .
84 c . . . . 1 : aucune face ne correspond .
85 c ______________________________________________________________________
88 c 0. declarations et dimensionnement
91 c 0.1. ==> generalites
97 parameter ( nompro = 'CMCP22' )
115 integer indare, indtri, indtet
117 integer hetare(nouvar), somare(2,nouvar)
118 integer filare(nouvar), merare(nouvar), famare(nouvar)
119 integer hettri(nouvtr), aretri(nouvtr,3)
120 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
121 integer nivtri(nouvtr)
122 integer filqua(nouvqu)
123 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
124 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
125 integer facpen(nouvpf,5), cofape(nouvpf,5)
126 integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
128 integer ulsort, langue, codret
130 c 0.4. ==> variables locales
134 #ifdef _DEBUG_HOMARD_
140 integer noemil(2), lesare(1)
143 integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
149 parameter ( nbmess = 10 )
150 character*80 texte(nblang,nbmess)
152 c 0.5. ==> initialisations
153 c ______________________________________________________________________
161 #ifdef _DEBUG_HOMARD_
162 write (ulsort,texte(langue,1)) 'Entree', nompro
174 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
175 c les faces du pentaedre et leurs codes
177 f2 = facpen(lepent,2)
178 cf2 = cofape(lepent,2)
179 #ifdef _DEBUG_HOMARD_
180 f1 = facpen(lepent,1)
181 cf1 = cofape(lepent,1)
182 f3 = facpen(lepent,3)
183 cf3 = cofape(lepent,3)
184 f4 = facpen(lepent,4)
185 cf4 = cofape(lepent,4)
186 f5 = facpen(lepent,5)
187 cf5 = cofape(lepent,5)
188 write(ulsort,90002) 'f1', f1, cf1
189 write(ulsort,90002) 'f2', f2, cf2
190 write(ulsort,90002) 'f3', f3, cf3
191 write(ulsort,90002) 'f4', f4, cf4
192 write(ulsort,90002) 'f5', f5, cf5
195 #ifdef _DEBUG_HOMARD_
196 write (ulsort,90015) 'Triangle', f2,
197 > ', aretes', (aretri(f2,jaux),jaux=1,3)
200 c 2.2. ==> grandeurs dependant du cas traite
201 c iaux = numero local de l'arete coupee
202 c jaux = numero global de l'arete coupee
203 c noemil = noeud milieu de l'arete coupee
207 noemil(1) = somare(2,filare(jaux))
211 noemil(2) = somare(2,filare(jaux))
213 #ifdef _DEBUG_HOMARD_
214 write(ulsort,90002) 'noemil', noemil
217 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
219 c trifad(1,0) = triangle central de la face 1 : FF4
220 c trifad(1,1) = triangle de la face 1 du cote de S2 : FF4 + 1/2
221 c trifad(1,2) = triangle de la face 1 du cote de S1 : FF4 + 2/1
222 c areqtr(1,1) : AS5N2
223 c areqtr(1,2) : AS4N2
225 c trifad(2,0) = triangle central de la face 2 : FF5
226 c trifad(2,1) = triangle de la face 2 du cote de F1 : FF5 + 1/2
227 c trifad(2,2) = triangle de la face 2 du cote de F2 : FF5 + 2/1
228 c areqtr(2,1) : AS2N9
229 c areqtr(2,2) : AS5N9
231 c trifad(3,0) = triangle central de la face 3 : FF3
232 c trifad(3,1) = triangle de la face 3 du cote de F1 : FF3 + 1/2
233 c trifad(3,2) = triangle de la face 3 du cote de F2 : FF3 + 2/1
234 c areqtr(3,1) : AS1N9
235 c areqtr(3,2) : AS4N9
237 c trifad(4,0) = triangle 1 de la face 4 : FF1 + 0/1 (FF1D3)
238 c trifad(4,1) = triangle 2 de la face 4 : FF1 + 1/0 (FF1D1)
239 c areqtr(4,1) : AS3N2
241 c areqtr(1,0) : AS2N2
242 c areqtr(2,0) : AS1N2
243 c areqtr(3,0) : AS3N9
245 if ( codret.eq.0 ) then
254 #ifdef _DEBUG_HOMARD_
255 write (ulsort,texte(langue,3)) 'CMCP2B', nompro
257 call cmcp2b ( nulofa, lepent,
259 > aretri, nivtri, filtri,
263 > trifad, cotrvo, areqtr,
264 > ulsort, langue, codret )
269 c 3. Creation du noeud interne
272 c 4. Creation de l'arete interne
277 #ifdef _DEBUG_HOMARD_
278 write (ulsort,91000) indare+1, indare+1
281 if ( codret.eq.0 ) then
286 somare(1,areint(1)) = min ( noemil(1) , noemil(2) )
287 somare(2,areint(1)) = max ( noemil(1) , noemil(2) )
289 famare(areint(1)) = 1
290 hetare(areint(1)) = 50
291 merare(areint(1)) = 0
292 filare(areint(1)) = 0
293 #ifdef _DEBUG_HOMARD_
294 write(ulsort,90006) 'areint(1) = ', areint(1),
295 > ' de ',somare(1,areint(1)),
296 > ' a ',somare(2,areint(1))
301 c 5. Creation des six triangles internes
310 #ifdef _DEBUG_HOMARD_
311 write (ulsort,92000) indtri+1, indtri+6
314 if ( codret.eq.0 ) then
316 lesare(1) = listar(5)
318 #ifdef _DEBUG_HOMARD_
319 write (ulsort,texte(langue,3)) 'CMCP2C', nompro
321 call cmcp2c ( indtri, triint,
323 > areint, areqtr, niveau,
324 > aretri, famtri, hettri,
325 > filtri, pertri, nivtri,
326 > ulsort, langue, codret )
330 #ifdef _DEBUG_HOMARD_
331 do 500 , iaux = indtri-5 , indtri
332 write (ulsort,90015) 'Triangle', iaux,
333 > ', aretes', (aretri(iaux,jaux),jaux=1,3)
338 c 6. Creation de la pyramide
342 c 7. Creation des 6 tetraedres
345 #ifdef _DEBUG_HOMARD_
346 write (ulsort,93000) indtet+1, indtet+6
349 if ( codret.eq.0 ) then
351 coface = per001(6,cf2)
353 #ifdef _DEBUG_HOMARD_
354 write (ulsort,texte(langue,3)) 'CMCP2E', nompro
356 call cmcp2e ( indtet, indptp,
358 > trifad, cotrvo, triint,
360 > hettet, tritet, cotrte,
361 > filtet, pertet, famtet,
363 > ulsort, langue, codret )
365 #ifdef _DEBUG_HOMARD_
366 do 700 , iaux = indtet-5 , indtet
367 write (ulsort,90015) 'Tetra', iaux,
368 > ', faces', (tritet(iaux,jaux),jaux=1,4)
369 write(ulsort,90015) 'Tetra', iaux,
370 > ', codes', (cotrte(iaux,jaux),jaux=1,4)
380 if ( codret.ne.0 ) then
384 write (ulsort,texte(langue,1)) 'Sortie', nompro
385 write (ulsort,texte(langue,2)) codret
389 #ifdef _DEBUG_HOMARD_
390 write (ulsort,texte(langue,1)) 'Sortie', nompro