1 subroutine cmcp21 ( 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 21 - par les aretes 1 et 8
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 = 'CMCP21' )
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 c 2.2. ==> grandeurs dependant du cas traite
196 c iaux = numero local de l'arete coupee
197 c jaux = numero global de l'arete coupee
198 c noemil = noeud milieu de l'arete coupee
202 noemil(1) = somare(2,filare(jaux))
206 noemil(2) = somare(2,filare(jaux))
208 #ifdef _DEBUG_HOMARD_
209 write(ulsort,90002) 'noemil', noemil
212 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
214 c trifad(1,0) = triangle central de la face 1 : FF3
215 c trifad(1,1) = triangle de la face 1 du cote de S1 : FF3 + 1/2
216 c trifad(1,2) = triangle de la face 1 du cote de S3 : FF3 + 2/1
217 c areqtr(1,1) : AS4N1
218 c areqtr(1,2) : AS6N1
220 c trifad(2,0) = triangle central de la face 2 : FF4
221 c trifad(2,1) = triangle de la face 2 du cote de F1 : FF4 + 1/2
222 c trifad(2,2) = triangle de la face 2 du cote de F2 : FF4 + 2/1
223 c areqtr(2,1) : AS1N8
224 c areqtr(2,2) : AS4N8
226 c trifad(3,0) = triangle central de la face 3 : FF5
227 c trifad(3,1) = triangle de la face 3 du cote de F1 : FF5 + 1/2
228 c trifad(3,2) = triangle de la face 3 du cote de F2 : FF5 + 2/1
229 c areqtr(3,1) : AS3N8
230 c areqtr(3,2) : AS6N8
232 c trifad(4,0) = triangle 1 de la face 4 : FF1 + 0/1 (FF1D2)
233 c trifad(4,1) = triangle 2 de la face 4 : FF1 + 1/0 (FF1D3)
234 c areqtr(4,1) : AS2N1
236 c areqtr(1,0) : AS1N1
237 c areqtr(2,0) : AS3N1
238 c areqtr(3,0) : AS2N8
240 if ( codret.eq.0 ) then
249 #ifdef _DEBUG_HOMARD_
250 write (ulsort,texte(langue,3)) 'CMCP2B', nompro
252 call cmcp2b ( nulofa, lepent,
254 > aretri, nivtri, filtri,
258 > trifad, cotrvo, areqtr,
259 > ulsort, langue, codret )
264 c 3. Creation du noeud interne
267 c 4. Creation de l'arete interne
272 #ifdef _DEBUG_HOMARD_
273 write (ulsort,91000) indare+1, indare+1
276 if ( codret.eq.0 ) then
281 somare(1,areint(1)) = min ( noemil(1) , noemil(2) )
282 somare(2,areint(1)) = max ( noemil(1) , noemil(2) )
284 famare(areint(1)) = 1
285 hetare(areint(1)) = 50
286 merare(areint(1)) = 0
287 filare(areint(1)) = 0
288 #ifdef _DEBUG_HOMARD_
289 write(ulsort,90006) 'areint(1) = ', areint(1),
290 > ' de ',somare(1,areint(1)),
291 > ' a ',somare(2,areint(1))
296 c 5. Creation des six triangles internes
305 #ifdef _DEBUG_HOMARD_
306 write (ulsort,92000) indtri+1, indtri+6
309 if ( codret.eq.0 ) then
311 lesare(1) = listar(4)
313 #ifdef _DEBUG_HOMARD_
314 write (ulsort,texte(langue,3)) 'CMCP2C', nompro
316 call cmcp2c ( indtri, triint,
318 > areint, areqtr, niveau,
319 > aretri, famtri, hettri,
320 > filtri, pertri, nivtri,
321 > ulsort, langue, codret )
323 #ifdef _DEBUG_HOMARD_
324 do 500 , iaux = indtri-5 , indtri
325 write (ulsort,90015) 'Triangle', iaux,
326 > ', aretes', (aretri(iaux,jaux),jaux=1,3)
333 c 6. Creation de la pyramide
337 c 7. Creation des 6 tetraedres
340 #ifdef _DEBUG_HOMARD_
341 write (ulsort,93000) indtet+1, indtet+6
344 if ( codret.eq.0 ) then
346 coface = per001(5,cf2)
348 #ifdef _DEBUG_HOMARD_
349 write (ulsort,texte(langue,3)) 'CMCP2E', nompro
351 call cmcp2e ( indtet, indptp,
353 > trifad, cotrvo, triint,
355 > hettet, tritet, cotrte,
356 > filtet, pertet, famtet,
358 > ulsort, langue, codret )
360 #ifdef _DEBUG_HOMARD_
361 do 700 , iaux = indtet-5 , indtet
362 write (ulsort,90015) 'Tetra', iaux,
363 > ', faces', (tritet(iaux,jaux),jaux=1,4)
364 write(ulsort,90015) 'Tetra', iaux,
365 > ', codes', (cotrte(iaux,jaux),jaux=1,4)
375 if ( codret.ne.0 ) then
379 write (ulsort,texte(langue,1)) 'Sortie', nompro
380 write (ulsort,texte(langue,2)) codret
384 #ifdef _DEBUG_HOMARD_
385 write (ulsort,texte(langue,1)) 'Sortie', nompro