1 subroutine pcs0pe ( lepent, profho,
2 > hetpen, facpen, cofape, filpen, fppyte,
7 > afaire, listar, listno, typdec, etanp1,
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 -
31 c interpolation p2 sur les noeuds - phase 0
33 c decoupage des PEntaedres
35 c ______________________________________________________________________
37 c . nom . e/s . taille . description .
38 c .____________________________________________________________________.
39 c . lepent . e . 1 . pentaedre a examiner .
40 c . profho . e . * . pour chaque entite en numerotation homard :.
41 c . . . . 0 : l'entite est absente du profil .
42 c . . . . 1 : l'entite est presente dans le profil .
43 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
44 c . facpen . e .nbpecf*5. numeros des faces des pentaedres .
45 c . cofape . e .nbpecf*5. codes des faces des pentaedres .
46 c . filpen . e . nbpeto . premier fils des pentaedres .
47 c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide .
48 c . . . . fille du pentaedre k tel que filpen(k) =-j .
49 c . . . . fppyte(2,j) = numero du 1er tetraedre .
50 c . . . . fils du pentaedre k tel que filpen(k) = -j .
51 c . somare . e .2*nbarto. numeros des extremites d'arete .
52 c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes .
53 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
54 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
55 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
56 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
57 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
58 c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides .
59 c . afaire . s . 1 . vrai si l'interpolation est a faire .
60 c . listar . s . 9 . liste des aretes du pentaedre .
61 c . listno . s . 15 . liste des noeuds du pentaedre .
62 c . typdec . s . 1 . type de decoupage .
63 c . etanp1 . s . 1 . etat du pentaedre a l'iteration N+1 .
64 c . noeumi . s . 1 . numero du noeud milieu .
65 c ______________________________________________________________________
68 c 0. declarations et dimensionnement
71 c 0.1. ==> generalites
89 integer profho(nbnoto)
90 integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5)
91 integer filpen(nbpeto), fppyte(2,nbpeco)
92 integer somare(2,nbarto), np2are(nbarto)
93 integer aretri(nbtrto,3)
94 integer arequa(nbquto,4)
95 integer tritet(nbtecf,4), cotrte(nbtecf,4)
96 integer facpyr(nbpycf,5), cofapy(nbpycf,5)
97 integer listar(9), listno(15)
98 integer typdec, etanp1
103 c 0.4. ==> variables locales
107 c etan = ETAt du pentaedre a l'iteration N
110 c ______________________________________________________________________
115 c 1. les seuls cas interessants sont ceux ou un noeud est cree a
116 c l'interieur du pentaedre, donc quand il y a une arete interne
119 etanp1 = mod(hetpen(lepent),100)
120 etan = (hetpen(lepent)-etanp1) / 100
121 cgn write(1,90001) 'etats du penta', lepent,etan,etanp1
122 cgn write(1,90002) 'faces', (facpen(lepent,iaux),iaux=1,5)
123 cgn write(1,90002) 'codes', (cofape(lepent,iaux),iaux=1,5)
128 c . l'eventuel noeud central
129 c decoupage selon 2 aretes tria/tria
130 c decoupage selon 1 face triangulaire
131 if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
132 > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
136 c . d'un milieu de faces a un autre (en 8)
137 if ( ( etanp1.eq.80 ) .and. ( etanp1.ne.etan ) ) then
141 c . du centre aux milieux d'aretes
142 c decoupage selon 2 aretes tria/tria
143 c decoupage selon 1 face triangulaire
144 if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
145 > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
149 c . du centre aux sommets
150 c decoupage selon 2 aretes tria/tria
151 c decoupage selon 1 face triangulaire
152 if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
153 > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
157 c . d'un milieu d'arete a un autre (aretes tria+quad)
158 if ( etanp1.ge.21 .and. etanp1.le.26 ) then
162 c . d'un milieu d'arete a un sommet (selon 1 arete tria)
163 if ( etanp1.ge. 1 .and. etanp1.le. 6 ) then
167 c . d'un milieu de face a un sommet (selon 1 face quad)
168 if ( etanp1.ge.43 .and. etanp1.le.45 ) then
172 cgn write(1,90002) 'typdec',typdec
175 c 2. Caracteristiques du pentaedre
178 if ( typdec.gt.1 ) then
180 c 2.1. ==> reperage des 9 aretes du pentaedre
182 call utarpe ( lepent,
184 > arequa, facpen, cofape,
186 cgn write(1,90002) 'listar', listar
188 c 2.2. ==> recuperation des 6 noeuds sommets
190 call utsope ( somare, listar, listno )
191 cgn write(1,90002) 'listno sommets', (listno(iaux),iaux=1,6))
193 c 2.3. ==> recuperation des 9 noeuds milieux
196 listno(6+iaux) = np2are(listar(iaux))
198 cgn write(1,90002) 'listno milieux', (listno(iaux),iaux=7,15))
203 c 3. on verifie que le champ est present sur tous les noeuds
207 if ( typdec.gt.1 ) then
210 do 31 , iaux = 1 , 15
211 if ( profho(listno(iaux)).eq.0 ) then
224 cgn write(1,*) 'afaire', afaire
227 c 4. S'il faudra interpoler avec l'eventuel noeud central :
232 if ( mod(typdec,2).eq.0 .or.
233 > mod(typdec,5).eq.0 .or.
234 > mod(typdec,7).eq.0 ) then
237 call utnmpe ( iaux, noeumi,
238 > somare, aretri, arequa,
240 > facpen, cofape, filpen, fppyte,