1 subroutine cmcp3f ( nulofa, lepent,
6 > aretri, nivtri, filtri,
10 > trifad, cotrvo, areqtr,
11 > ulsort, langue, codret )
13 c ______________________________________________________________________
17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
20 c aupres des huissiers de justice Simart et Lavoir a Clamart
21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
22 c aupres des huissiers de justice
23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
25 c HOMARD est une marque deposee d'Electricite de France
31 c ______________________________________________________________________
33 c Creation du Maillage - Conformite - decoupage des Pentaedres
37 c Reperage des aretes et des triangles sur les faces externes
38 c Remarque : cmcp3b et cmcp3f sont des clones
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . nulofa . e . 4 . numero local des faces a traiter .
44 c . lepent . e . 1 . pentaedre a decouper .
45 c . indi1 . e . 1 . i1i2i3 associe a l'arete coupee face i .
46 c . indi2 . e . 1 . i1i2i3 associe a l'arete du cote de pyra .
47 c . indi3 . e . 1 . i1i2i3 associe a l'arete oppose a la pyra .
48 c . ind001 . e . 4 . redirection dans per001 .
49 c . somare . e .2*nouvar. numeros des extremites d'arete .
50 c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles .
51 c . nivtri . e . nouvtr . niveau des triangles .
52 c . filtri . e . nouvtr . premier fils des triangles .
53 c . filqua . e . nouvqu . premier fils des quadrangles .
54 c . facpen . e .nouvpf*5. numeros des faces des pentaedres .
55 c . cofape . e .nouvpf*5. codes des faces des pentaedres .
56 c . niveau . s . 1 . niveau des faces issus du decoupage .
57 c . trifad . s .(4,0:2) . triangles traces sur les faces decoupees .
58 c . cotrvo . s .(4,0:2) . code des triangles dans les volumes .
59 c . areqtr . s .(4,0:2) . aretes tri tracees sur les faces decoupees .
60 c . ulsort . e . 1 . unite logique de la sortie generale .
61 c . langue . e . 1 . langue des messages .
62 c . . . . 1 : francais, 2 : anglais .
63 c . codret . es . 1 . code de retour des modules .
64 c . . . . 0 : pas de probleme .
65 c . . . . 1 : aucune arete ne correspond .
66 c ______________________________________________________________________
69 c 0. declarations et dimensionnement
72 c 0.1. ==> generalites
78 parameter ( nompro = 'CMCP3F' )
92 integer lepent, nulofa(4)
93 integer ind11(6), ind12(6), ind13(6)
94 integer ind21(6), ind22(6), ind23(6)
96 integer somare(2,nouvar)
97 integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr)
98 integer filqua(nouvqu)
99 integer facpen(nouvpf,5), cofape(nouvpf,5)
101 integer areqtr(4,0:2)
102 integer trifad(4,0:2), cotrvo(4,0:2)
104 integer ulsort, langue, codret
106 c 0.4. ==> variables locales
111 parameter ( nbmess = 10 )
112 character*80 texte(nblang,nbmess)
114 c 0.5. ==> initialisations
115 c ______________________________________________________________________
123 #ifdef _DEBUG_HOMARD_
124 write (ulsort,texte(langue,1)) 'Entree', nompro
134 c 2. Triangles et aretes tracees sur les quadrangles coupees en 3
135 c On traite les faces du pentaedre coupees en 3 comme suit :
136 c La 1ere face est celle qui contient l'arete de F1 coupee.
137 c trifad(p,0) : triangle central de ce decoupage
138 c trifad(p,1) : triangle bordant l'arete non decoupee qui
139 c appartient a la pyramide
140 c trifad(p,2) : triangle bordant l'arete non decoupee qui
141 c n'appartient pas a la pyramide
142 c areqtr(p,1) : arete interne au quadrangle de bord et bordant le
143 c triangle trifad(p,1)
144 c areqtr(p,2) : arete interne au quadrangle de bord et bordant le
145 c triangle trifad(p,2)
146 c areqtr(3/4,0) = fille de l'arete coupee, du cote de la pyramide
147 c areqtr(3/4,1) = autre fille
152 iaux = facpen(lepent,nulofa(1))
153 jaux = cofape(lepent,nulofa(1))
154 trifad(1,0) = -filqua(iaux)
155 if ( jaux.lt.5 ) then
157 trifad(1,1) = trifad(1,0) + 2
159 trifad(1,2) = trifad(1,0) + 1
161 areqtr(1,1) = aretri(trifad(1,0),3)
162 areqtr(1,2) = aretri(trifad(1,0),1)
165 trifad(1,1) = trifad(1,0) + 1
167 trifad(1,2) = trifad(1,0) + 2
169 areqtr(1,1) = aretri(trifad(1,0),1)
170 areqtr(1,2) = aretri(trifad(1,0),3)
172 areqtr(3,0) = aretri(trifad(1,1),1)
173 areqtr(3,1) = aretri(trifad(1,2),1)
174 #ifdef _DEBUG_HOMARD_
175 write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
176 do 2221 , iaux = 0, 2
177 write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux),
178 > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3)
180 write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0),
181 > 'cotrvo(1,1) = ', cotrvo(1,1),
182 > 'cotrvo(1,2) = ', cotrvo(1,2)
183 write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1),
184 > ' de ',somare(1,areqtr(1,1)),
185 > ' a ',somare(2,areqtr(1,1))
186 write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2),
187 > ' de ',somare(1,areqtr(1,2)),
188 > ' a ',somare(2,areqtr(1,2))
189 write(ulsort,90006) 'areqtr(3,0) = ', areqtr(3,0),
190 > ' de ',somare(1,areqtr(3,0)),
191 > ' a ',somare(2,areqtr(3,0))
192 write(ulsort,90006) 'areqtr(3,1) = ', areqtr(3,1),
193 > ' de ',somare(1,areqtr(3,1)),
194 > ' a ',somare(2,areqtr(3,1))
199 iaux = facpen(lepent,nulofa(2))
200 jaux = cofape(lepent,nulofa(2))
201 trifad(2,0) = -filqua(iaux)
202 if ( jaux.lt.5 ) then
204 trifad(2,1) = trifad(2,0) + 2
206 trifad(2,2) = trifad(2,0) + 1
208 areqtr(2,1) = aretri(trifad(2,0),3)
209 areqtr(2,2) = aretri(trifad(2,0),1)
212 trifad(2,1) = trifad(2,0) + 1
214 trifad(2,2) = trifad(2,0) + 2
216 areqtr(2,1) = aretri(trifad(2,0),1)
217 areqtr(2,2) = aretri(trifad(2,0),3)
219 areqtr(4,0) = aretri(trifad(2,1),1)
220 areqtr(4,1) = aretri(trifad(2,2),1)
221 #ifdef _DEBUG_HOMARD_
222 write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
223 do 2222 , iaux = 0, 2
224 write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux),
225 > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3)
227 write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0),
228 > 'cotrvo(2,1) = ', cotrvo(2,1),
229 > 'cotrvo(2,2) = ', cotrvo(2,2)
230 write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1),
231 > ' de ',somare(1,areqtr(2,1)),
232 > ' a ',somare(2,areqtr(2,1))
233 write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2),
234 > ' de ',somare(1,areqtr(2,2)),
235 > ' a ',somare(2,areqtr(2,2))
236 write(ulsort,90006) 'areqtr(4,0) = ', areqtr(4,0),
237 > ' de ',somare(1,areqtr(4,0)),
238 > ' a ',somare(2,areqtr(4,0))
239 write(ulsort,90006) 'areqtr(4,1) = ', areqtr(4,1),
240 > ' de ',somare(1,areqtr(4,1)),
241 > ' a ',somare(2,areqtr(4,1))
245 c 3. Triangles et aretes tracees sur les triangles coupes en 2
246 c On traite les faces du pentaedre coupees en 3 comme suit :
247 c La 1ere face est F1.
248 c trifad(p,0) : triangle bordant la pyramide
249 c trifad(p,1) : triangle autre
250 c areqtr(p,2) : arete commune aux deux triangles fils
254 iaux = facpen(lepent,nulofa(3))
255 jaux = cofape(lepent,nulofa(3))
256 trifad(3,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux))
257 trifad(3,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux))
258 areqtr(3,2) = aretri(trifad(3,0),ind13(jaux))
260 cotrvo(3,0) = per001(ind001(1),jaux)
261 cotrvo(3,1) = per001(ind001(2),jaux)
262 #ifdef _DEBUG_HOMARD_
263 write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux
264 do 3331 , iaux = 0, 1
265 write (ulsort,90015) 'trifad(3,0/1) =', trifad(3,iaux),
266 > ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3)
268 write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0),
269 > 'cotrvo(3,1) = ', cotrvo(3,1)
270 write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2),
271 > ' de ',somare(1,areqtr(3,2)),
272 > ' a ',somare(2,areqtr(3,2))
277 iaux = facpen(lepent,nulofa(4))
278 jaux = cofape(lepent,nulofa(4))
279 trifad(4,0) = filtri(iaux) + nutrde(ind21(jaux),ind22(jaux))
280 trifad(4,1) = filtri(iaux) + nutrde(ind21(jaux),ind23(jaux))
281 areqtr(4,2) = aretri(trifad(4,0),ind23(jaux))
283 cotrvo(4,0) = per001(ind001(3),jaux)
284 cotrvo(4,1) = per001(ind001(4),jaux)
285 #ifdef _DEBUG_HOMARD_
286 write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux
287 do 3332 , iaux = 0, 1
288 write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux),
289 > ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3)
291 write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0),
292 > 'cotrvo(4,1) = ', cotrvo(4,1)
293 write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2),
294 > ' de ',somare(1,areqtr(4,2)),
295 > ' a ',somare(2,areqtr(4,2))
299 c 4. niveau des triangles des conformites des faces
302 niveau = nivtri(trifad(1,0))
303 #ifdef _DEBUG_HOMARD_
304 write(ulsort,90002) 'niveau', niveau
311 if ( codret.ne.0 ) then
315 write (ulsort,texte(langue,1)) 'Sortie', nompro
316 write (ulsort,texte(langue,2)) codret
320 #ifdef _DEBUG_HOMARD_
321 write (ulsort,texte(langue,1)) 'Sortie', nompro