1 subroutine pcsepz ( propor,
3 > coonoe, somare, aretri, arequa,
4 > tritet, cotrte, aretet,
5 > facpen, cofape, arepen,
6 > facpyr, cofapy, arepyr,
8 > ulsort, langue, codret )
9 c ______________________________________________________________________
13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
16 c aupres des huissiers de justice Simart et Lavoir a Clamart
17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
18 c aupres des huissiers de justice
19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
21 c HOMARD est une marque deposee d'Electricite de France
27 c ______________________________________________________________________
29 c aPres adaptation - Conversion de Solution Elements de volume -
31 c Pentaedres - calcul des proportions fils/pere
33 c ______________________________________________________________________
35 c . nom . e/s . taille . description .
36 c .____________________________________________________________________.
37 c . propor . s . 11 . proportion de volume entre fils et pere .
38 c . lepent . e . 1 . hexaedre courant .
39 c . etat . e . 1 . etat du pentaedre .
40 c . coonoe . e . nbnoto . coordonnees des noeuds .
42 c . somare . e .2*nbarto. numeros des extremites d'arete .
43 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
44 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
45 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
46 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
47 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
48 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
49 c . cofape . e .nbpecf*5. code des 5 faces des pentaedres .
50 c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres .
51 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
52 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
53 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
54 c . filpen . e . nbpeto . premier fils des pentaedres .
55 c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide .
56 c . . . . fille du pentaedre k tel que filpen(k) =-j .
57 c . . . . fppyte(2,j) = numero du 1er tetraedre .
58 c . . . . fils du pentaedre k tel que filpen(k) = -j .
59 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
60 c . langue . e . 1 . langue des messages .
61 c . . . . 1 : francais, 2 : anglais .
62 c . codret . es . 1 . code de retour des modules .
63 c . . . . 0 : pas de probleme .
64 c . . . . 1 : probleme .
65 c ______________________________________________________________________
68 c 0. declarations et dimensionnement
71 c 0.1. ==> generalites
77 parameter ( nompro = 'PCSEPZ' )
96 integer somare(2,nbarto)
97 integer aretri(nbtrto,3)
98 integer arequa(nbquto,4)
99 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
100 integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
101 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
103 integer filpen(nbpeto), fppyte(2,nbpeco)
105 double precision propor(11)
106 double precision coonoe(nbnoto,sdim)
108 integer ulsort, langue, codret
110 c 0.4. ==> variables locales
113 integer fipent, fipyra, fitetr
114 integer nfpent, nfpyra, nftetr, nbfils
116 double precision daux
117 double precision daux0
120 parameter ( nbmess = 10 )
121 character*80 texte(nblang,nbmess)
123 c 0.5. ==> initialisations
124 c ______________________________________________________________________
133 #ifdef _DEBUG_HOMARD_
134 write (ulsort,texte(langue,1)) 'Entree', nompro
142 #ifdef _DEBUG_HOMARD_
143 write (ulsort,texte(langue,4)) lepent, etat
147 c 2. denombrement des fils pour les differents cas de figure
149 c 2.0. ==> a priori, aucun
155 c 2.1. ==> etat = 1, ..., 6 :
156 c decoupage en 1 tetraedre et 2 pyramides
158 if ( etat.ge.1 .and. etat.le.6 ) then
163 c 2.2. ==> etat = 17, ..., 19 :
164 c decoupage en 2 tetraedres et 1 pyramide.
166 elseif ( etat.ge.17 .and. etat.le.19 ) then
171 c 2.3. ==> etat = 21, ..., 26 :
172 c decoupage en 6 tetraedres
174 elseif ( etat.ge.21 .and. etat.le.26 ) then
178 c 2.4. ==> etat = 31, ..., 36 :
179 c decoupage en 10 tetraedres et 1 pyramide.
181 elseif ( etat.ge.31 .and. etat.le.36 ) then
186 c 2.5. ==> etat = 43, ..., 45 :
187 c decoupage en 2 tetraedres et 4 pyramides
189 elseif ( etat.ge.43 .and. etat.le.45 ) then
194 c 2.6. ==> etat = 51, 52 :
195 c decoupage en 11 tetraedres
197 elseif ( etat.ge.51 .and. etat.le.52 ) then
201 c 2.7. ==> etat = 80 :
202 c decoupage en 8 pentaedres.
204 elseif ( etat.eq.80 .or. etat.eq.99 ) then
210 #ifdef _DEBUG_HOMARD_
211 write (ulsort,90002) 'nfpent', nfpent
212 write (ulsort,90002) 'nfpyra', nfpyra
213 write (ulsort,90002) 'nftetr', nftetr
219 c 3.1. ==> Calcul des volumes
220 c Remarque : certains des volumes des fils sont identiques
221 c par paires, par construction. On les calcule quand meme
222 c pour la lisibilite du programme.
224 nbfils = nfpent + nfpyra + nftetr
226 c 3.1.1. ==> Pentaedres
228 if ( nfpent.gt.0 ) then
230 fipent = filpen(lepent) - 1
231 do 321 , iaux = 1, nfpent
232 call utvpen ( fipent+iaux, propor(iaux),
233 > coonoe, somare, arequa,
234 > facpen, cofape, arepen )
239 c 3.1.2. ==> Pyramides
241 if ( nfpyra.gt.0 ) then
243 fipyra = fppyte(1,-filpen(lepent)) - 1
244 do 322 , iaux = 1 , nfpyra
245 call utvpyr ( fipyra+iaux, propor(iaux),
246 > coonoe, somare, aretri,
247 > facpyr, cofapy, arepyr )
252 c 3.1.3. ==> Tetraedres
254 if ( nftetr.gt.0 ) then
256 fitetr = fppyte(2,-filpen(lepent)) - 1
257 do 323 , iaux = 1 , nftetr
258 call utvtet ( fitetr+iaux, propor(iaux+nfpyra),
259 > coonoe, somare, aretri,
260 > tritet, cotrte, aretet )
265 c 3.2. ==> Le volume total ; c'est donc le volume du pere
268 do 32 , iaux = 1, nbfils
269 daux0 = daux0 + propor(iaux)
274 do 33 , iaux = 1, nbfils
275 propor(iaux) = propor(iaux) / daux0
278 #ifdef _DEBUG_HOMARD_
279 if ( nfpent.gt.0 ) then
280 write (ulsort,90015) 'propor pour les', nfpent, ' pentaedres'
281 do 3391 , iaux = 1, nfpent
282 write (ulsort,90014) iaux, propor(iaux)
285 if ( nfpyra.eq.1 ) then
286 write (ulsort,90015) 'propor pour la pyramide'
287 write (ulsort,90014) 1, propor(1)
288 elseif ( nfpyra.gt.0 ) then
289 write (ulsort,90015) 'propor pour les', nfpyra, ' pyramides'
290 do 3392 , iaux = 1, nfpyra
291 write (ulsort,90014) iaux, propor(iaux)
294 if ( nftetr.eq.1 ) then
295 write (ulsort,90015) 'propor pour le tetradre'
296 write (ulsort,90014) 1, propor(1+nfpyra)
297 elseif ( nftetr.gt.0 ) then
298 write (ulsort,90015) 'propor pour les', nftetr, ' tetradres'
299 do 3393 , iaux = 1, nftetr
300 write (ulsort,90014) iaux, propor(iaux+nfpyra)
309 if ( codret.ne.0 ) then
311 write (ulsort,texte(langue,1)) 'Sortie', nompro
312 write (ulsort,texte(langue,2)) codret
316 #ifdef _DEBUG_HOMARD_
317 write (ulsort,texte(langue,1)) 'Sortie', nompro