1 subroutine pcsep1 ( etan, etanp1, pehn, pehnp1, typint,
3 > nfpyrn, nftetn, ficn,
4 > nfpyrp, nftetp, ficp, propor,
9 > tritet, cotrte, aretet,
10 > facpen, cofape, arepen,
11 > facpyr, cofapy, arepyr,
12 > hetpen, filpen, fppyte,
21 > ulsort, langue, codret )
22 c ______________________________________________________________________
26 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
28 c Version originale enregistree le 18 juin 1996 sous le numero 96036
29 c aupres des huissiers de justice Simart et Lavoir a Clamart
30 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
31 c aupres des huissiers de justice
32 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
34 c HOMARD est une marque deposee d'Electricite de France
40 c ______________________________________________________________________
42 c aPres adaptation - Conversion de Solution Elements de volume -
44 c Pentaedres - decoupage par conformite avant
46 c remarque : pcseh1 et pcsep1 sont des clones
47 c ______________________________________________________________________
49 c . nom . e/s . taille . description .
50 c .____________________________________________________________________.
51 c . etan . e . 1 . ETAt du pentaedre a l'iteration N .
52 c . etanp1 . e . 1 . ETAt du pentaedre a l'iteration N+1 .
53 c . pehn . e . 1 . PEntaedre courant en numerotation Homard .
54 c . . . . a l'iteration N .
55 c . pehnp1 . e . 1 . PEntaedre courant en numerotation Homard .
56 c . . . . a l'iteration N+1 .
57 c . typint . e . 1 . type d'interpolation .
58 c . . . . 0, si automatique .
59 c . . . . elements : 0 si intensif, sans orientation.
60 c . . . . 1 si extensif, sans orientation.
61 c . . . . 2 si intensif, avec orientation.
62 c . . . . 3 si extensif, avec orientation.
63 c . . . . noeuds : 1 si degre 1 .
64 c . . . . 2 si degre 2 .
65 c . . . . 3 si iso-P2 .
66 c . prfcap . es . * . En numero du calcul a l'iteration n+1 : .
67 c . . . . 0 : l'entite est absente du profil .
68 c . . . . 1 : l'entite est presente dans le profil .
69 c . nfpyrn . e . 1 . nombre de fils pyramides n .
70 c . nftetn . e . 1 . nombre de fils tetraedres n .
71 c . ficn . e . 3,11 . fils en numerotation du calcul n .
72 c . . . . 1 : pentaedres .
73 c . . . . 2 : pyramides .
74 c . . . . 3 : tetraedres .
75 c . nfpyrp . e . 1 . nombre de fils pyramides n+1 .
76 c . nftetp . e . 1 . nombre de fils tetraedres n+1 .
77 c . ficp . e . 3,11 . fils en numerotation du calcul n+1 .
78 c . . . . 1 : pentaedres .
79 c . . . . 2 : pyramides .
80 c . . . . 3 : tetraedres .
81 c . propor . e . 11 . proportion de volume entre fils et pere .
82 c . coonoe . e . nbnoto . coordonnees des noeuds .
84 c . somare . e .2*nbarto. numeros des extremites d'arete .
85 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
86 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
87 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
88 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
89 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
90 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
91 c . cofape . e .nbpecf*5. code des 5 faces des pentaedres .
92 c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres .
93 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
94 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
95 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
96 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
97 c . filpen . e . nbpeto . premier fils des pentaedres .
98 c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide .
99 c . . . . fille du pentaedre k tel que filpen(k) =-j .
100 c . . . . fppyte(2,j) = numero du 1er tetraedre .
101 c . . . . fils du pentaedre k tel que filpen(k) = -j .
102 c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie.
103 c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie.
104 c . npysca . e . rspyto . numero des pyramides dans le calcul sortie .
105 c . nbfonc . e . 1 . nombre de fonctions elements de volume .
106 c . vafott . es . nbfonc*. variables en sortie de l'adaptation .
108 c . vateen . e . nbfonc*. variables en entree de l'adaptation pour .
109 c . . . * . les tetraedres .
110 c . vatett . a . nbfonc*. tableau temporaire de la solution pour .
111 c . . . * . les tetraedres .
112 c . prften . es . * . En numero du calcul a l'iteration n : .
113 c . . . . 0 : le tetraedre est absent du profil .
114 c . . . . 1 : le tetraedre est present dans le profil.
115 c . prftep . es . * . En numero du calcul a l'iteration n+1 : .
116 c . . . . 0 : le tetraedre est absent du profil .
117 c . . . . 1 : le tetraedre est present dans le profil.
118 c . vapyen . e . nbfonc*. variables en entree de l'adaptation pour .
119 c . . . * . les pyramides .
120 c . vapytt . a . nbfonc*. tableau temporaire de la solution pour .
121 c . . . * . les pyramides .
122 c . prfpyn . es . * . En numero du calcul a l'iteration n : .
123 c . . . . 0 : la pyramide est absente du profil .
124 c . . . . 1 : la pyramide est presente dans le profil.
125 c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : .
126 c . . . . 0 : la pyramide est absente du profil .
127 c . . . . 1 : la pyramide est presente dans le profil
128 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
129 c . langue . e . 1 . langue des messages .
130 c . . . . 1 : francais, 2 : anglais .
131 c . codret . es . 1 . code de retour des modules .
132 c . . . . 0 : pas de probleme .
133 c . . . . 1 : probleme .
134 c ______________________________________________________________________
137 c 0. declarations et dimensionnement
140 c 0.1. ==> generalites
146 parameter ( nompro = 'PCSEP1' )
164 integer etan, etanp1, pehn, pehnp1
169 integer nfpyrn, nftetn
171 integer nfpyrp, nftetp
174 integer somare(2,nbarto)
175 integer aretri(nbtrto,3)
176 integer arequa(nbquto,4)
177 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
178 integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
179 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
181 integer hetpen(nbpeto), filpen(nbpeto), fppyte(2,nbpeco)
182 integer npesca(rsheto)
183 integer ntesca(rsteto)
184 integer npysca(rspyto)
185 integer prften(*), prftep(*)
186 integer prfpyn(*), prfpyp(*)
188 double precision propor(11)
189 double precision coonoe(nbnoto,sdim)
190 double precision vafott(nbfonc,*)
191 double precision vateen(nbfonc,*)
192 double precision vatett(nbfonc,*)
193 double precision vapyen(nbfonc,*)
194 double precision vapytt(nbfonc,*)
196 integer ulsort, langue, codret
198 c 0.4. ==> variables locales
209 double precision daux
210 double precision daux1
213 parameter ( nbmess = 10 )
214 character*80 texte(nblang,nbmess)
216 c 0.5. ==> initialisations
217 c ______________________________________________________________________
225 #ifdef _DEBUG_HOMARD_
226 write (ulsort,texte(langue,1)) 'Entree', nompro
234 c 2. seulement si des valeurs existent
239 do 21 , iaux = 1 , nfpyrn
240 if ( prfpyn(ficn(2,iaux)).eq.0 ) then
245 do 22 , iaux = 1 , nftetn
246 if ( prften(ficn(3,iaux)).eq.0 ) then
253 cgn write(ulsort,90002) 'etanp1', etanp1
254 cgn write(ulsort,90002) 'pehnp1', pehnp1
255 cgn write(ulsort,90002) 'nfpyrn, nftetn', nfpyrn, nftetn
256 daux1 = 1.d0 / dble(nfpyrn+nftetn)
259 c 3. Le pentaedre etait coupe en conformite
261 c 3.1. ==> etanp1 = 0 : le pentaedre est reactive.
262 c 0n lui attribue la valeur moyenne ou totale sur les
264 c remarque : cela arrive seulement avec du deraffinement.
266 if ( etanp1.eq.0 ) then
267 cgn write(ulsort,*) '... le pentaedre est reactive'
269 pecnp1 = npesca(pehnp1)
270 cgn write(ulsort,*) 'prfcap pour',pecnp1
273 if ( typint.eq.0 ) then
275 do 310 , nrofon = 1 , nbfonc
278 do 3101 , iaux = 1 , nfpyrn
279 daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
281 do 3102 , iaux = 1 , nftetn
282 daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
285 vafott(nrofon,pecnp1) = daux * daux1
291 do 311 , nrofon = 1 , nbfonc
293 do 3111 , iaux = 1 , nfpyrn
294 daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
296 do 3112 , iaux = 1 , nftetn
297 daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
299 vafott(nrofon,pecnp1) = daux
304 c 3.2. ==> etanp1 = etan : le pentaedre est decoupe selon
305 c le meme decoupage. Comme les conventions sont les memes,
306 c on remet les memes valeurs.
308 elseif ( etanp1.eq.etan ) then
310 do 32 , nrofon = 1 , nbfonc
311 do 321 , iaux = 1 , nfpyrn
312 vapytt(nrofon,ficp(2,iaux)) =
313 > vapyen(nrofon,prfpyn(ficn(2,iaux)))
315 do 322 , iaux = 1 , nftetn
316 vatett(nrofon,ficp(3,iaux)) =
317 > vateen(nrofon,prften(ficn(3,iaux)))
321 c 3.3. ==> un autre decoupage de conformite
323 elseif ( ( etanp1.ge. 1 .and. etanp1.le. 6 ) .or.
324 > ( etanp1.ge.17 .and. etanp1.le.19 ) .or.
325 > ( etanp1.ge.21 .and. etanp1.le.26 ) .or.
326 > ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
327 > ( etanp1.ge.43 .and. etanp1.le.45 ) .or.
328 > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
330 if ( typint.eq.0 ) then
332 do 330 , nrofon = 1 , nbfonc
335 do 3301 , iaux = 1 , nfpyrn
336 daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
338 do 3302 , iaux = 1 , nftetn
339 daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
343 do 3303 , iaux = 1 , nfpyrp
344 vapytt(nrofon,ficp(2,iaux)) = daux
346 do 3304 , iaux = 1 , nftetp
347 vatett(nrofon,ficp(3,iaux)) = daux
354 do 331 , nrofon = 1 , nbfonc
357 do 3311 , iaux = 1 , nfpyrn
358 daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
360 do 3312 , iaux = 1 , nftetn
361 daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
364 do 3313 , iaux = 1 , nfpyrp
365 vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux)
367 do 3314 , iaux = 1 , nftetp
368 vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp)
375 c 3.4. ==> etanp1 = 80 : le pentaedre est coupe en 8 pentaedres
376 c c'est ce qui se passe quand un decoupage de conformite
377 c est supprime au debut des algorithmes d'adaptation. il y
378 c a ensuite raffinement du pentaedre. qui plus est, par
379 c suite de la regle des ecarts de niveau, on peut avoir
380 c induit un decoupage de conformite sur 1,2,3 ou 4 des fils.
381 c Ce ou ces fils sont obligatoirement du cote du precedent
382 c point de non conformite.
384 elseif ( etanp1.eq.80 ) then
385 cgn print *,'... le penta est coupe en 8 penta'
387 f1hp = filpen(pehnp1)
388 daux1 = 1.d0 / dble(nfpyrn+nftetn)
389 cgn write(ulsort,*) 'f1hp = ', f1hp
390 do 34 , nrofon = 1 , nbfonc
393 do 3401 , iaux = 1 , nfpyrn
394 daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
396 do 3402 , iaux = 1 , nftetn
397 daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
401 #ifdef _DEBUG_HOMARD_
402 write (ulsort,texte(langue,3)) 'PCSEP9', nompro
404 call pcsep9 ( etan, etanp1, pehn, pehnp1, typint,
405 > f1hp, iaux, daux, daux1, prfcap,
407 > coonoe, somare, aretri, arequa,
408 > tritet, cotrte, aretet,
409 > facpen, cofape, arepen,
410 > facpyr, cofapy, arepyr,
411 > hetpen, filpen, fppyte,
418 > ulsort, langue, codret )
425 c 4. affectation des profils
426 c Attention : pour les fils en pentaedres, c'est fait dans pcsep9
429 if ( codret.eq.0 ) then
431 do 42 , iaux = 1 , nfpyrp
432 prfpyp(ficp(2,iaux)) = 1
435 do 43 , iaux = 1 , nftetp
436 prftep(ficp(3,iaux)) = 1
447 if ( codret.ne.0 ) then
449 write (ulsort,texte(langue,1)) 'Sortie', nompro
450 write (ulsort,texte(langue,2)) codret
454 #ifdef _DEBUG_HOMARD_
455 write (ulsort,texte(langue,1)) 'Sortie', nompro