1 subroutine cmcp18 ( lepent, listar,
2 > indtri, indtet, indpyr,
5 > filtri, pertri, famtri,
8 > hettet, tritet, cotrte,
9 > filtet, pertet, famtet,
10 > hetpyr, facpyr, cofapy,
11 > filpyr, perpyr, fampyr,
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 18 - par l'arete de quadrangle 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 . indtri . es . 1 . indice du dernier triangle cree .
46 c . indtet . es . 1 . indice du dernier tetraedre cree .
47 c . indpyr . es . 1 . indice de la derniere pyramide creee .
48 c . indptp . e . 1 . indice du dernier pere enregistre .
49 c . hettri . es . nouvtr . historique de l'etat des triangles .
50 c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles .
51 c . filtri . es . nouvtr . premier fils des triangles .
52 c . pertri . es . nouvtr . pere des triangles .
53 c . famtri . es . nouvtr . famille des triangles .
54 c . nivtri . es . nouvtr . niveau des triangles .
55 c . filqua . e . nouvqu . premier fils des quadrangles .
56 c . hettet . es . nouvte . historique de l'etat des tetraedres .
57 c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres .
58 c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres .
59 c . filtet . es . nouvte . premier fils des tetraedres .
60 c . pertet . es . nouvte . pere des tetraedres .
61 c . . . . si pertet(i) > 0 : numero du tetraedre .
62 c . . . . si pertet(i) < 0 : -numero dans pthepe .
63 c . famtet . es . nouvte . famille des tetraedres .
64 c . hetpyr . es . nouvpy . historique de l'etat des pyramides .
65 c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides .
66 c . cofapy . es .nouvyf*5. codes des faces des pyramides .
67 c . filpyr . es . nouvpy . premier fils des pyramides .
68 c . perpyr . es . nouvpy . pere des pyramides .
69 c . . . . si perpyr(i) > 0 : numero de la pyramide .
70 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
71 c . fampyr . es . nouvpy . famille des pyramides .
72 c . facpen . e .nouvpf*5. numeros des faces des pentaedres .
73 c . cofape . e .nouvpf*5. codes des faces des pentaedres .
74 c . fampen . e . nouvpe . famille des penaedres .
75 c . cfapen . e . nctfpe*. codes des familles des pentaedres .
76 c . . . nbfpen . 1 : famille MED .
77 c . . . . 2 : type de pentaedres .
78 c . . . . 3 : famille des tetraedres de conformite .
79 c . . . . 4 : famille des pyramides de conformite .
80 c . . . . 3 : famille des tetraedres de conformite .
81 c . . . . 4 : famille des pyramides de conformite .
82 c . ulsort . e . 1 . unite logique de la sortie generale .
83 c . langue . e . 1 . langue des messages .
84 c . . . . 1 : francais, 2 : anglais .
85 c . codret . es . 1 . code de retour des modules .
86 c . . . . 0 : pas de probleme .
87 c . . . . 1 : aucune face ne correspond .
88 c ______________________________________________________________________
91 c 0. declarations et dimensionnement
94 c 0.1. ==> generalites
100 parameter ( nompro = 'CMCP18' )
118 integer indtri, indtet, indpyr
120 integer hettri(nouvtr), aretri(nouvtr,3)
121 integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
122 integer nivtri(nouvtr)
123 integer filqua(nouvqu)
124 integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
125 integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
126 integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
127 integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
128 integer facpen(nouvpf,5), cofape(nouvpf,5)
129 integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
131 integer ulsort, langue, codret
133 c 0.4. ==> variables locales
139 #ifdef _DEBUG_HOMARD_
144 integer tab1(4), tab2(4)
146 integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2)
151 parameter ( nbmess = 10 )
152 character*80 texte(nblang,nbmess)
154 c 0.5. ==> initialisations
155 c ______________________________________________________________________
163 #ifdef _DEBUG_HOMARD_
164 write (ulsort,texte(langue,1)) 'Entree', nompro
176 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
177 c les faces du pentaedre et leurs codes
179 f1 = facpen(lepent,1)
180 cf1 = cofape(lepent,1)
181 f2 = facpen(lepent,2)
182 cf2 = cofape(lepent,2)
183 f3 = facpen(lepent,3)
184 cf3 = cofape(lepent,3)
185 #ifdef _DEBUG_HOMARD_
186 cf4 = cofape(lepent,4)
187 f4 = facpen(lepent,4)
188 cf5 = cofape(lepent,5)
189 f5 = facpen(lepent,5)
190 write(ulsort,90002) 'f1', f1, cf1
191 write(ulsort,90002) 'f2', f2, cf2
192 write(ulsort,90002) 'f3', f3, cf3
193 write(ulsort,90002) 'f4', f4, cf4
194 write(ulsort,90002) 'f5', f5, cf5
197 c 2.2. ==> Triangles et aretes tracees sur les quadrangles coupes
199 c trifad(1,0) = triangle central de la face 1 : FF5
200 c trifad(1,1) = triangle de la face 1 du cote de F1 : FF5 + 1/2
201 c trifad(1,2) = triangle de la face 1 du cote de F2 : FF5 + 2/1
202 c areqtr(1,1) : AS3N8
203 c areqtr(1,2) : AS6N8
205 c trifad(2,0) = triangle central de la face 1 : FF4
206 c trifad(2,1) = triangle de la face 1 du cote de F1 : FF4 + 1/2
207 c trifad(2,2) = triangle de la face 1 du cote de F2 : FF4 + 2/1
208 c areqtr(2,1) : AS1N8
209 c areqtr(2,2) : AS1N8
211 if ( codret.eq.0 ) then
216 #ifdef _DEBUG_HOMARD_
217 write (ulsort,texte(langue,3)) 'CMCP1B', nompro
219 call cmcp1b ( nulofa, lepent,
224 > trifad, cotrvo, areqtr,
225 > ulsort, langue, codret )
230 c 3. Creation du noeud interne
233 c 4. Creation de l'arete interne
236 c 5. Creation des deux triangles internes
237 c triint(1) : le triangle interne du cote de F1
238 c triint(2) : le triangle interne du cote de F2
243 #ifdef _DEBUG_HOMARD_
244 write (ulsort,92000) indtri+1, indtri+2
247 if ( codret.eq.0 ) then
249 lesare(1) = listar(1)
250 lesare(2) = listar(4)
252 #ifdef _DEBUG_HOMARD_
253 write (ulsort,texte(langue,3)) 'CMCP1C', nompro
255 call cmcp1c ( indtri, triint,
258 > aretri, famtri, hettri,
259 > filtri, pertri, nivtri,
260 > ulsort, langue, codret )
265 c 6. Creation de la pyramide
268 #ifdef _DEBUG_HOMARD_
269 write (ulsort,95000) indpyr+1, indpyr+1
273 jaux = cfapen(cofpfp,fampen(lepent))
276 #ifdef _DEBUG_HOMARD_
277 write (ulsort,texte(langue,3)) 'CMCPYR', nompro
279 call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
281 > trifad(1,0), cotrvo(1,0),
283 > trifad(2,0), cotrvo(2,0),
285 > iaux, jaux, indpyr )
287 #ifdef _DEBUG_HOMARD_
288 do 600 , iaux = indpyr , indpyr
289 write (ulsort,90015) 'Pyra', iaux,
290 > ', faces', (facpyr(iaux,jaux),jaux=1,5)
291 write (ulsort,90015) 'Pyra', iaux,
292 > ', codes', (cofapy(iaux,jaux),jaux=1,5)
297 c 7. Creation des 2 tetraedres
300 #ifdef _DEBUG_HOMARD_
301 write (ulsort,93000) indtet+1, indtet+2
304 if ( codret.eq.0 ) then
307 tab2(1) = per001(5,cf1)
310 tab2(2) = per001(5,cf2)
312 #ifdef _DEBUG_HOMARD_
313 write (ulsort,texte(langue,3)) 'CMCP1E', nompro
315 call cmcp1e ( indtet, indptp,
317 > trifad, cotrvo, triint,
319 > hettet, tritet, cotrte,
320 > filtet, pertet, famtet,
322 > ulsort, langue, codret )
324 #ifdef _DEBUG_HOMARD_
325 do 700 , iaux = indtet-1 , indtet
326 write (ulsort,90015) 'Tetra', iaux,
327 > ', faces', (tritet(iaux,jaux),jaux=1,4)
328 write (ulsort,90015) 'Tetra', iaux,
329 > ', codes', (cotrte(iaux,jaux),jaux=1,4)
339 if ( codret.ne.0 ) then
343 write (ulsort,texte(langue,1)) 'Sortie', nompro
344 write (ulsort,texte(langue,2)) codret
348 #ifdef _DEBUG_HOMARD_
349 write (ulsort,texte(langue,1)) 'Sortie', nompro